source: project/release/3/fmt/fmt-chicken.scm @ 10190

Last change on this file since 10190 was 10190, checked in by Alex Shinn, 12 years ago

Updating to version 0.513.

File size: 3.2 KB
Line 
1;;;; fmt-chicken.scm -- Chicken fmt extension
2;;
3;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6(require-extension (srfi 1 6 13 69))
7
8(cond-expand
9 (compiling
10  (declare
11   (not usual-integrations + - * / expt log < <= > >= = abs
12        quotient remainder modulo arithmetic-shift number? exact? inexact?
13        inexact->exact exact->inexact even? odd? zero? positive? negative?
14        number->string)
15   (export
16    new-fmt-state
17    fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind fmt-null
18    fmt-ref fmt-set! fmt-add-properties! fmt-set-property!
19    fmt-col fmt-set-col! fmt-row fmt-set-row!
20    fmt-radix fmt-set-radix! fmt-precision fmt-set-precision!
21    fmt-properties fmt-set-properties! fmt-width fmt-set-width!
22    fmt-writer fmt-set-writer! fmt-port fmt-set-port!
23    fmt-decimal-sep fmt-set-decimal-sep!
24    copy-fmt-state
25    fmt-file fmt-try-fit cat apply-cat nl fl nl-str
26    fmt-join fmt-join/last fmt-join/dot
27    fmt-join/prefix fmt-join/suffix fmt-join/range
28    pad pad/right pad/left pad/both trim trim/left trim/both trim/length
29    fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp
30    pretty pretty/unshared slashified maybe-slashified
31    num num/si num/fit num/comma radix fix ellipses
32    upcase downcase titlecase pad-char comma-char decimal-char
33    with-width wrap-lines fold-lines justify
34    make-string-fmt-transformer
35    make-space make-nl-space display-to-string write-to-string
36    fmt-columns columnar line-numbers
37    mantissa+exponent
38    )))
39 (else))
40
41(define (make-eq?-table) (make-hash-table eq?))
42
43(cond-expand
44 (compiling
45  (cond-expand
46   (big-endian
47    (define %mantissa
48      (foreign-lambda*
49       number ((double f))
50       "unsigned long long *n = (unsigned long long*)&f;
51        return((*n) >> 12uLL);"))
52    (define %exponent
53      (foreign-lambda*
54       number ((double f))
55       "unsigned long long *n = (unsigned long long*)&f;
56        return(((*n) >> 1uLL) & ((1uLL<<11uLL)-1uLL));")))
57   (else  ;; little-endian
58    (define %mantissa
59      (foreign-lambda*
60       number ((double f))
61       "unsigned long long *n = (unsigned long long*)&f;
62        return((*n) & ((1uLL<<52uLL)-1uLL));"))
63    (define %exponent
64      (foreign-lambda*
65       number ((double f))
66       "unsigned long long *n = (unsigned long long*)&f;
67        return(((*n) >> 52uLL) & ((1uLL<<11uLL)-1uLL));"))))
68  (define (mantissa+exponent num)
69    (let ((e (%exponent num))
70          (m (%mantissa num)))
71      (cond
72       ((= e #x7FF)
73        (list 0 0))
74       ((zero? e)
75        (list m e))
76       (else
77        (list (+ m (* (arithmetic-shift 1 22)
78                      (arithmetic-shift 1 30)))
79              (- e #x3FF 52)))))))
80 (else
81  (define (mantissa+exponent num . opt)
82    (if (zero? num)
83        (list 0 0)
84        (let-optionals* opt ((base 2) (mant-size 52) (exp-size 11))
85          (let* ((bot (expt base mant-size))
86                 (top (* base bot)))
87            (let lp ((n num) (e 0))
88              (cond
89                ((>= n top) (lp (quotient n base) (+ e 1)))
90                ((< n bot) (lp (* n base) (- e 1)))
91                (else (list n e))))))))
92  ))
93
94(include "fmt.scm")
95(include "fmt-pretty.scm")
96(include "fmt-column.scm")
97
Note: See TracBrowser for help on using the repository browser.