Changeset 10150 in project


Ignore:
Timestamp:
03/25/08 15:12:21 (12 years ago)
Author:
Alex Shinn
Message:

Several bugfixes in number formatting.

Location:
release/3/fmt/trunk
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • release/3/fmt/trunk/fmt-c-chicken.scm

    r9924 r10150  
    44;; BSD-style license: http://synthcode.com/license.txt
    55
    6 (use srfi-1 srfi-13)
    76(use fmt)
    87
  • release/3/fmt/trunk/fmt-c.scm

    r9924 r10150  
    9393               (cat (c-type (cadr x)) "[]")))
    9494          ((%fun)
    95            (cat (c-type (cadr x)) " (*) (" (join c-type (caddr x) ", ") ")"))
    96           (else (join c-type x ""))))
     95           (cat (c-type (cadr x)) " (*) (" (fmt-join c-type (caddr x) ", ") ")"))
     96          (else (fmt-join c-type x ""))))
    9797       ((not x) (cat (fmt-default-type st)))
    9898       (else
     
    256256    'paren
    257257    (cat (c-expr (car ls))
    258          (let ((flat (fmt-let 'no-wrap? #t (join c-expr (cdr ls) ", "))))
     258         (let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
    259259           (fmt-if
    260260            fmt-no-wrap?
     
    266266                (let* ((col (fmt-col st))
    267267                       (sep (string-append "," (make-nl-space col))))
    268                   ((join c-expr (cdr ls) sep) st)))))))))))
     268                  ((fmt-join c-expr (cdr ls) sep) st)))))))))))
    269269
    270270(define (c-expr x)
     
    383383            (cat fl "#define " (name-of (car x))
    384384                 (c-paren
    385                   (join/dot name-of
    386                             (lambda (dot) (dsp "..."))
    387                             (cdr x)
    388                             ", "))
     385                  (fmt-join/dot name-of
     386                                (lambda (dot) (dsp "..."))
     387                                (cdr x)
     388                                ", "))
    389389                 tail fl)
    390390            (cat fl "#define " (c-expr x) tail fl)))
     
    445445
    446446(define (cpp-sym-cat . args)
    447   (join dsp args " ## "))
     447  (fmt-join dsp args " ## "))
    448448
    449449;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    511511         (if (fmt-expression? st)
    512512             ((fmt-try-fit
    513                (fmt-let 'no-wrap? #t (join c-expr (cons body0 body) ", "))
     513               (fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
    514514               (lambda (st)
    515515                 (let ((indent (c-current-indent-string st)))
    516                    ((join c-expr (cons body0 body) (cat "," nl indent)) st))))
     516                   ((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
    517517              st)
    518518             (let ((orig-ret? (fmt-return? st)))
    519                ((join/last c-expr
    520                            (lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
    521                            (cons body0 body)
    522                            (cat fl (c-current-indent-string st)))
     519               ((fmt-join/last c-expr
     520                               (lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
     521                               (cons body0 body)
     522                               (cat fl (c-current-indent-string st)))
    523523                (fmt-set! st 'return? (and ret? orig-ret?))))))))
    524524
     
    527527
    528528(define (c-typedef what name . o)
    529   (let ((tail (join/prefix c-expr o " ")))
     529  (let ((tail (fmt-join/prefix c-expr o " ")))
    530530    (c-wrap-stmt
    531531     (cond
    532532       ((and (pair? what) (eq? '%fun (car what)))
    533533        (cat "typedef " (c-type (cadr what)) " (*" (c-expr name) ")"
    534              " (" (join c-type (caddr what) ", ") ")" tail))
     534             " (" (fmt-join c-type (caddr what) ", ") ")" tail))
    535535       ((and (pair? what) (eq? '%array (car what)))
    536536        (cat "typedef " (c-type (cadr what))
     
    571571
    572572(define (c-attribute . args)
    573   (cat "__attribute__ ((" (join c-expr args ", ") "))"))
     573  (cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
    574574
    575575;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    597597
    598598(define (c-param-list ls)
    599   (c-in-expr (join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))
     599  (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))
    600600
    601601(define (c-fun type name params . body)
     
    608608  (c-wrap-stmt
    609609   (cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
    610         (join/prefix c-expr o " "))))
     610        (fmt-join/prefix c-expr o " "))))
    611611
    612612(define (c-static x) (cat "static " (c-expr x)))
     
    633633         (cat base-type " " (c-expr name) array-suffix
    634634              " = " (if (and array? (vector? (car init)))
    635                         (cat "{" (join c-expr (vector->list (car init)) ", ") "}")
     635                        (cat "{" (fmt-join c-expr (vector->list (car init)) ", ") "}")
    636636                        (c-expr (car init))))
    637637         (cat base-type " " (if (pair? name)
    638                                 (join c-expr name ", ")
     638                                (fmt-join c-expr name ", ")
    639639                                (c-expr name))
    640640              array-suffix)))))
     
    723723           (sep (string-append ":" nl-str indent)))
    724724      ((cat (c-in-expr
    725              (join/suffix
     725             (fmt-join/suffix
    726726              dsp
    727727              (if (pair? (cadr x))
     
    731731              sep))
    732732            (make-space (or (fmt-indent-space st) 4))
    733             (join c-expr (cddr x) indent-body)
     733            (fmt-join c-expr (cddr x) indent-body)
    734734            (if (and break? (not (fmt-return? st)))
    735735                (cat fl indent-body c-break)
     
    764764      op
    765765      (if (or (equal? str ".") (equal? str "->"))
    766           (join c-expr ls str)
     766          (fmt-join c-expr ls str)
    767767          (let ((flat
    768768                 (fmt-let 'no-wrap? #t
    769769                          (lambda (st)
    770                             ((join c-expr ls (if (and (fmt-non-spaced-ops? st)
    771                                                       (every lit-op? ls))
    772                                                  str
    773                                                  (string-append " " str " ")))
     770                            ((fmt-join c-expr
     771                                       ls
     772                                       (if (and (fmt-non-spaced-ops? st)
     773                                                (every lit-op? ls))
     774                                           str
     775                                           (string-append " " str " ")))
    774776                             st)))))
    775777            (fmt-if
     
    779781              flat
    780782              (lambda (st)
    781                    ((join c-expr
    782                           ls
    783                           (cat nl (make-space (+ 2 (fmt-col st))) str " "))
     783                   ((fmt-join c-expr
     784                              ls
     785                              (cat nl (make-space (+ 2 (fmt-col st))) str " "))
    784786                    st))))))))))
    785787
  • release/3/fmt/trunk/fmt-chicken.scm

    r9924 r10150  
    44;; BSD-style license: http://synthcode.com/license.txt
    55
    6 (use srfi-1 srfi-13 srfi-6 srfi-69)
     6(require-extension (srfi 1 6 13 69))
    77
    88(cond-expand
    99 (compiling
    1010  (declare
    11    (not usual-integrations + - * / expt log < <= > >= =
    12         quotient remainder modulo arithmetic-shift number?
    13         inexact->exact exact->inexact even? odd? zero? positive? negative?)
     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)
    1415   (export
    1516    new-fmt-state
     
    2324    copy-fmt-state
    2425    fmt-file fmt-try-fit cat apply-cat nl fl nl-str
    25     join join/last join/dot join/prefix join/suffix join/range
     26    fmt-join fmt-join/last fmt-join/dot
     27    fmt-join/prefix fmt-join/suffix fmt-join/range
    2628    pad pad/right pad/left pad/both trim trim/left trim/both trim/length
    2729    fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp
     
    3941
    4042(cond-expand
    41  ((and compiling no-such-feature) ; non-portable, disabling for now
     43 (compiling
    4244  (cond-expand
    4345   (big-endian
  • release/3/fmt/trunk/fmt-column.scm

    r9924 r10150  
    182182       (error "invalid column" (car ls))))))
    183183
    184 ;; break lines only, don't join short lines or justify
     184;; break lines only, don't fmt-join short lines or justify
    185185(define (fold-lines . ls)
    186186  (lambda (st)
     
    275275(define (wrap-lines . ls)
    276276  (define (print-line ls st)
    277     (nl ((join dsp ls " ") st)))
     277    (nl ((fmt-join dsp ls " ") st)))
    278278  (define buffer '())
    279279  (lambda (st)
     
    313313               st))))
    314314      (define (justify-last ls st)
    315         (nl ((join dsp ls " ") st)))
     315        (nl ((fmt-join dsp ls " ") st)))
    316316      ((fmt-let
    317317        'writer
     
    334334(define (line-numbers . o)
    335335  (let ((start (if (pair? o) (car o) 1)))
    336     (join/range dsp start #f nl-str)))
    337 
     336    (fmt-join/range dsp start #f nl-str)))
     337
  • release/3/fmt/trunk/fmt-pretty.scm

    r9924 r10150  
    3737          (proc st)))))
    3838
    39 (define (join/shares fmt ls . o)
     39(define (fmt-join/shares fmt ls . o)
    4040  (let ((sep (dsp (if (pair? o) (car o) " "))))
    4141    (lambda (st)
     
    117117           (st2 (fmt-copy-shares st))
    118118           (first-line
    119             ((fmt-to-string (cat " " (join/shares pp-flat fixed " "))) st2))
     119            ((fmt-to-string (cat " " (fmt-join/shares pp-flat fixed " "))) st2))
    120120           (default
    121121             (let ((sep (make-nl-space (+ col1 1))))
    122                (cat sep (join/shares pp-object (cdr ls) sep) ")"))))
     122               (cat sep (fmt-join/shares pp-object (cdr ls) sep) ")"))))
    123123      (if (< (+ col2 (string-length first-line)) (fmt-width st2))
    124124          ;; fixed values on first line
     
    127127            ((cat first-line
    128128                  (if (> (length+ (cdr ls)) (or indent-rule 1))
    129                       (cat sep (join/shares pp-object tail sep))
     129                      (cat sep (fmt-join/shares pp-object tail sep))
    130130                      "")
    131131                  ")")
     
    137137                  ((cat
    138138                    " "
    139                     (join/shares pp-object fixed (make-nl-space (+ col2 1)))
     139                    (fmt-join/shares pp-object fixed (make-nl-space (+ col2 1)))
    140140                    (if (pair? tail)
    141141                        (let ((sep (make-nl-space (+ col1 2))))
    142                           (cat sep (join/shares pp-object tail sep)))
     142                          (cat sep (fmt-join/shares pp-object tail sep)))
    143143                        "")
    144144                    ")")
     
    176176              (cat (cdr abbrev) (pp-flat (cadr x)))))
    177177        (else
    178          (cat "(" (join/shares pp-flat x " ") ")")))))
     178         (cat "(" (fmt-join/shares pp-flat x " ") ")")))))
    179179    ((vector? x)
    180      (fmt-shared-write x (cat "#(" (join pp-flat (vector->list x) " ") ")")))
     180     (fmt-shared-write x (cat "#(" (fmt-join pp-flat (vector->list x) " ") ")")))
    181181    (else (lambda (st) ((write-with-shares x (fmt-shares st)) st)))))
    182182
     
    232232        (else
    233233         ;; no room, print one per line
    234          ((cat (join pp-object ls (make-nl-space col)) ")") st))))))
     234         ((cat (fmt-join pp-object ls (make-nl-space col)) ")") st))))))
    235235
    236236(define (pp-vector vec)
  • release/3/fmt/trunk/fmt-unicode-chicken.scm

    r9924 r10150  
    44;; BSD-style license: http://synthcode.com/license.txt
    55
    6 (use srfi-4)
    76(use utf8-lolevel)
    8 (use fmt)
    97
    108(cond-expand
  • release/3/fmt/trunk/fmt.meta

    r9924 r10150  
    66 (category io)
    77 (author "Alex Shinn")
    8  (needs utf8)
     8 (doc-from-wiki)
    99 (files "fmt.setup"
    10         "fmt.html"
    1110        "fmt-chicken.scm" "fmt.scm" "fmt-pretty.scm" "fmt-column.scm"
    1211        "fmt-c-chicken.scm" "fmt-c.scm"
    13         "fmt-color-chicken.scm" "fmt-color.scm"
     12        "fmt-color.scm" "fmt-color-chicken.scm"
    1413        "fmt-unicode-chicken.scm"))
  • release/3/fmt/trunk/fmt.scm

    r9924 r10150  
    99;;; string utilities
    1010
    11 (cond-expand
    12  (chicken)
    13  (else
    14   (define (call-with-output-string proc)
    15     (let ((p (open-output-string)))
    16       (proc p)
    17       (get-output-string p))) ) )
     11(define (call-with-output-string proc)
     12  (let ((p (open-output-string)))
     13    (proc p)
     14    (get-output-string p)))
    1815
    1916(define (write-to-string x)
     
    317314          st))))
    318315
    319 (define (join fmt ls . o)
     316(define (fmt-join fmt ls . o)
    320317  (let ((sep (dsp (if (pair? o) (car o) ""))))
    321318    (lambda (st)
     
    328325                (lp (cdr ls) ((fmt (car ls)) (sep st)))))))))
    329326
    330 (define (join/prefix fmt ls . o)
     327(define (fmt-join/prefix fmt ls . o)
    331328  (if (null? ls)
    332329      fmt-null
    333330      (let ((sep (dsp (if (pair? o) (car o) ""))))
    334         (cat sep (join fmt ls sep)))))
    335 
    336 (define (join/suffix fmt ls . o)
     331        (cat sep (fmt-join fmt ls sep)))))
     332(define (fmt-join/suffix fmt ls . o)
    337333  (if (null? ls)
    338334      fmt-null
    339335      (let ((sep (dsp (if (pair? o) (car o) ""))))
    340         (cat (join fmt ls sep) sep))))
    341 
    342 (define (join/last fmt fmt/last ls . o)
     336        (cat (fmt-join fmt ls sep) sep))))
     337
     338(define (fmt-join/last fmt fmt/last ls . o)
    343339  (let ((sep (dsp (if (pair? o) (car o) ""))))
    344340    (lambda (st)
     
    355351               (lp (cdr ls) ((fmt (car ls)) (sep st))))))))))
    356352
    357 (define (join/dot fmt fmt/dot ls . o)
     353(define (fmt-join/dot fmt fmt/dot ls . o)
    358354  (let ((sep (dsp (if (pair? o) (car o) ""))))
    359355    (lambda (st)
     
    369365        (else ((fmt/dot ls) st))))))
    370366
    371 (define (join/range fmt start . o)
     367(define (fmt-join/range fmt start . o)
    372368  (let-optionals* o ((end #f) (sep ""))
    373369    (lambda (st)
     
    598594        (define (write-positive n)
    599595
    600           (let* ((m+e (mantissa+exponent n))
     596          (let* ((m+e (mantissa+exponent (exact->inexact n)))
    601597                 (f (car m+e))
    602598                 (e (cadr m+e))
     
    621617                (cond
    622618                  ((>= i 0)
    623                    (if (and commify? (positive? i)
    624                             (zero? (modulo i comma-rule)))
     619                   (if (and commify?
     620                            (if digits
     621                                (and (> i digits)
     622                                     (zero? (modulo (- i (- digits 1))
     623                                                    comma-rule)))
     624                                (and (positive? i)
     625                                     (zero? (modulo i comma-rule)))))
    625626                       (display comma-sep port))
    626627                   (if (= i (- digits 1))
     
    698699                       (display decimal-sep port))
    699700                      ((and commify?
    700                             (positive? i) (zero? (modulo i comma-rule)))
     701                            (positive? i)
     702                            (zero? (modulo i comma-rule)))
    701703                       (display comma-sep port)))
    702704                (let ((d (quotient r s))
     
    718720                        ((= i (- digits 1))
    719721                         (display decimal-sep port))
    720                         ((and commify? (> i (- digits 1))
    721                               (zero? (modulo (- i (- digits 1)) comma-rule)))
     722                        ((and commify?
     723                              (> i digits)
     724                              (zero? (modulo (- i (- digits 1))
     725                                             comma-rule)))
    722726                         (display comma-sep port)))
    723727                  (let ((d (quotient r s))
    724728                        (r (remainder r s)))
    725729                    (if (zero? i)
    726                         (write-digit (if (< (* r 2) s) d (+ d 1)))
     730                        (write-digit (if (and (bigger (+ r m+) s)
     731                                              (>= (* r 2) s))
     732                                         (+ d 1)
     733                                         d))
    727734                        (if (smaller r m-)
    728735                            (if (bigger (+ r m+) s)
     
    981988                        (not (fmt-precision st)))
    982989                   (lambda (n st) (output (number->string n) st)))
    983                   ((assq (fmt-radix st)
     990                  ((assv (fmt-radix st)
    984991                         '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))
    985992                   => (lambda (cell)
Note: See TracChangeset for help on using the changeset viewer.