Changeset 9267 in project


Ignore:
Timestamp:
03/07/08 21:55:28 (12 years ago)
Author:
Kon Lovett
Message:

Added proc to get format argument.

Location:
release/3/format-modular/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/format-modular/trunk/format-modular.scm

    r9261 r9267  
    107107          *formatter-out-char-list
    108108          *formatter-out-string
     109          ;
     110          *formatter-next-argument
    109111          ;   Maker
    110112          make-format-function
     
    407409      obj ) ) )
    408410
     411(define (*formatter-next-argument state . rest)
     412  (let-optionals rest ((inctimes 1))
     413    (state-obj-ref state inctimes) ) )
     414
    409415(define (state-fmtend-push! state func)
    410416  (state-fmtend-set! state (cons func (state-fmtend state))) )
     
    470476            (let ((nlidx (string-index str #\newline)))
    471477              (if nlidx
    472                 (do ((ptr nlidx (string-index str #\newline (fx+ 1 ptr)))
    473                      (cur 0 ptr) )
    474                     ((not ptr) (substr-conv cur))
    475                   (write-string (substr-conv cur ptr) #f (state-out state))
    476                   (state-colpos-set! state 0)
    477                   ((state-caseconv state) #\newline) )
    478                 (substr-conv)))
     478                  (do ((ptr nlidx (string-index str #\newline (fx+ 1 ptr)))
     479                       (cur 0 ptr) )
     480                      ((not ptr) (substr-conv cur))
     481                    (write-string (substr-conv cur ptr) #f (state-out state))
     482                    (state-colpos-set! state 0)
     483                    ((state-caseconv state) #\newline) )
     484                  (substr-conv)))
    479485            #f (state-out state)) ) ) )
    480486
     
    497503                        str ) ) ) ) )
    498504        (lambda (state times char)
    499           (cond
    500             ((not state)
    501               (set! ht (make-hash-table fixnum+char-eq? fixnum+char-hash)))
    502             ((fx= 1 times)
    503               (*formatter-out-char state char))
    504             ((fx< 0 times)
    505               (*formatter-out-string state (times+char-memeoize times char))) ) ) ) ) )
     505          (cond ((not state)
     506                  (set! ht (make-hash-table fixnum+char-eq? fixnum+char-hash)))
     507                ((fx= 1 times)
     508                  (*formatter-out-char state char))
     509                ((fx< 0 times)
     510                  (*formatter-out-string state (times+char-memeoize times char))) ) ) ) ) )
    506511
    507512  (else
     
    527532  (*formatter-out-char-times state
    528533    (fx+ (if atsign colnum 0)
    529        (cond
    530          ((and (not atsign) (fx< (state-colpos state) colnum))
    531            (fx- colnum (state-colpos state)))
    532          ((fx= 0 colinc)
    533            0)
    534          (else
    535            (let ((mod (fxmod (fx+ (if atsign colnum 0) (state-colpos state)) colinc)))
    536              (if (fx= 0 mod) 0 (fx- colinc mod))))))
     534       (cond ((and (not atsign) (fx< (state-colpos state) colnum))
     535               (fx- colnum (state-colpos state)))
     536             ((fx= 0 colinc)
     537               0)
     538             (else
     539               (let ((mod (fxmod (fx+ (if atsign colnum 0) (state-colpos state)) colinc)))
     540                 (if (fx= 0 mod) 0 (fx- colinc mod))))))
    537541     tabchar) )
    538542
     
    548552  (let ((fmt (state-fmt state))
    549553        (pos (state-fmtpos state)))
    550     (cond
    551       ((fx< pos (string-length fmt))
    552        (state-fmtpos-set! state (fx+ 1 (state-fmtpos state)))
    553        ((vector-ref (state-table state) (char->integer (string-ref fmt pos)))
    554          state start params colon atsign) )
    555       (else
    556         (*formatter-out-char state #\~) ) ) ) )
     554    (cond ((fx< pos (string-length fmt))
     555           (state-fmtpos-set! state (fx+ 1 (state-fmtpos state)))
     556           ((vector-ref (state-table state) (char->integer (string-ref fmt pos)))
     557             state start params colon atsign) )
     558          (else
     559            (*formatter-out-char state #\~) ) ) ) )
    557560
    558561; Process the entire format string; when done, call the first
     
    566569      (state-fmtpos-set! state (fx+ 1 pos))
    567570      (if (eq? c (state-escape state))
    568         (format-escape state pos '() #f #f)
    569         (when (cond-valid? state)
    570           (*formatter-out-char state c) ) ) ) )
     571          (format-escape state pos '() #f #f)
     572          (when (cond-valid? state)
     573            (*formatter-out-char state c) ) ) ) )
    571574  (unless (null? (state-fmtend state))
    572575    ((car (state-fmtend state)))
     
    584587        (for-each
    585588          (if case-sensitive
    586             (lambda (binding)
    587               (vector-set! table (char->integer (car binding)) (cadr binding)))
    588             (lambda (binding)
    589               (vector-set! table (char->integer (char-upcase   (car binding))) (cadr binding))
    590               (vector-set! table (char->integer (char-downcase (car binding))) (cadr binding))))
     589              (lambda (binding)
     590                (vector-set! table (char->integer (car binding)) (cadr binding)))
     591              (lambda (binding)
     592                (vector-set! table (char->integer (char-upcase   (car binding))) (cadr binding))
     593                (vector-set! table (char->integer (char-downcase (car binding))) (cadr binding))))
    591594          definitions))
    592595      (reverse formatters))
     
    602605           (formatter
    603606            (lambda (out . args)
    604               (cond
    605                 ((not out)
    606                  (call-with-output-string (lambda (out) (apply formatter out args))) )
    607                 ((boolean? out)
    608                  (apply formatter (current-output-port) args) )
    609                 ((string? out)
    610                  (apply formatter #f out args) )
    611                 ((output-port? out)
    612                   (unless (pair? args)
    613                     (formatter-error "bad argument count - received 1 but expected 2" formatter) )
    614                   (format-parse
    615                     (make-default-state table escape out (car args) (cdr args))) )
    616                 (else
    617                   (formatter-error "invalid destination" out) ) ) ) ) )
     607              (cond ((not out)
     608                     (call-with-output-string (lambda (out) (apply formatter out args))) )
     609                    ((boolean? out)
     610                     (apply formatter (current-output-port) args) )
     611                    ((string? out)
     612                     (apply formatter #f out args) )
     613                    ((output-port? out)
     614                      (unless (pair? args)
     615                        (formatter-error "bad argument count - received 1 but expected 2" formatter) )
     616                      (format-parse
     617                        (make-default-state table escape out (car args) (cdr args))) )
     618                    (else
     619                      (formatter-error "invalid destination" out) ) ) ) ) )
    618620    formatter ) )
    619621
     
    646648  (let ((newpos (fx+ advance (state-fmtpos state))))
    647649    (state-fmtpos-set! state
    648       (if (and new (char=? (string-ref (state-fmt state) newpos) #\,))
    649         (fx+ newpos 1)
    650         newpos)) )
     650      (if (and new
     651               (char=? (string-ref (state-fmt state) newpos) #\,))
     652          (fx+ newpos 1)
     653          newpos)) )
    651654  (format-escape state start (cons new params) colon atsign))
    652655
     
    658661  (let ((c (string-ref fmt i)))
    659662    (if (or (char-numeric? c) (char=? c #\+) (char=? c #\-))
    660       (skip-number fmt (fx+ i 1))
    661       i)))
     663        (skip-number fmt (fx+ i 1))
     664        i)))
    662665
    663666; Formatter function to call when the escape character is
     
    782785      (and (not (and at-least-once (fx= 0 (iterator-runs it))))
    783786           (if (iterator-colon it)
    784              (fx<= (vector-length (iterator-itobj it)) (iterator-itobjpos it))
    785              (fx<= (vector-length (state-obj state)) (state-objpos state))))))
     787               (fx<= (vector-length (iterator-itobj it)) (iterator-itobjpos it))
     788               (fx<= (vector-length (state-obj state)) (state-objpos state))))))
    786789
    787790; Formatter function called to begin the iteration (when ~{ is
     
    798801                     0
    799802                     (if (null? params)
    800                        (and format:iteration-bounded format:max-iterations)
    801                        (car params))
     803                         (and format:iteration-bounded format:max-iterations)
     804                         (car params))
    802805                     (state-obj state)
    803806                     ; When @ then termination objpos is state-objpos since
     
    825828        (start-iteration state it start params colon atsign))
    826829      (if (iterator-stop? state it colon)
    827         (stop-iteration state it start)
    828         (resume-iteration state it start params colon atsign) ) ) ) )
     830          (stop-iteration state it start)
     831          (resume-iteration state it start params colon atsign) ) ) ) )
    829832
    830833; Start iterating: set itobj and itobjpos to valid values (if needed) and set
     
    851854
    852855(define (up-and-out-check? state params)
    853   (cond
    854     ((null? params)
    855      (fx= (state-objpos state) (vector-length (state-obj state))))
    856     ((null? (cdr params))
    857      (fx= 0 (first params)))
    858     ((null? (cddr params))
    859      (fx= (first params) (second params)))
    860     (else
    861       (let ((m (second params)))
    862         (and (fx<= (first params) m) (fx<= m (third params))) ) ) ) )
     856  (cond ((null? params)
     857         (fx= (state-objpos state) (vector-length (state-obj state))))
     858        ((null? (cdr params))
     859         (fx= 0 (first params)))
     860        ((null? (cddr params))
     861         (fx= (first params) (second params)))
     862        (else
     863          (let ((m (second params)))
     864            (and (fx<= (first params) m) (fx<= m (third params))) ) ) ) )
    863865
    864866(define (formatter-iteration-up-and-out)
     
    866868    (lambda (state start params colon atsign)
    867869      (when (up-and-out-check? state params)
    868         (cond
    869           ((null? (state-nest state))
    870            (state-fmtpos-set! state (string-length (state-fmt state))))
    871           ((char=? #\{ (car (state-nest state)))
    872            (iterator-maxruns-set! (car (state-iterate state)) 0)
    873            (state-condskip-pop! state)
    874            (state-condskip-push! state -1)))))))
     870        (cond ((null? (state-nest state))
     871               (state-fmtpos-set! state (string-length (state-fmt state))))
     872              ((char=? #\{ (car (state-nest state)))
     873               (iterator-maxruns-set! (car (state-iterate state)) 0)
     874               (state-condskip-pop! state)
     875               (state-condskip-push! state -1)))))))
    875876
    876877;`~{STR~}'
     
    920921    (lambda (c)
    921922      (let ((func (if current char-upcase char-downcase)))
    922         (cond
    923           ((or (char-numeric? c) (char-alphabetic? c))
    924            (set! current inner))
    925           (else
    926             (set! current start-rest)
    927             (set! inner inner-rest)))
     923        (cond ((or (char-numeric? c) (char-alphabetic? c))
     924               (set! current inner))
     925              (else
     926                (set! current start-rest)
     927                (set! inner inner-rest)))
    928928        (func c)))))
    929929
     
    992992          (let loop ((fmtpos (state-fmtpos state)))
    993993            (if (fx>= fmtpos fmtlen)
    994               fmtlen
    995               (let ((char (string-ref fmt fmtpos)))
    996                 (if (char-whitespace? char)
    997                   (begin
    998                     (when colon
    999                       (*formatter-out-char state char))
    1000                     (loop (fx+ fmtpos 1)))
    1001                   fmtpos)))))))))
     994                fmtlen
     995                (let ((char (string-ref fmt fmtpos)))
     996                  (if (char-whitespace? char)
     997                      (begin
     998                        (when colon
     999                          (*formatter-out-char state char))
     1000                        (loop (fx+ fmtpos 1)))
     1001                      fmtpos)))))))))
    10021002
    10031003; `~%'
     
    10631063(define (add-comma char width result)
    10641064  (if char
    1065     (let ((width-remaining (fx- width 1)))
    1066       (let ((result
    1067             (cdr
    1068               (fold-right
    1069                 (lambda (c rest)
    1070                   (let ((remwid (car rest)))
    1071                     (if (fx= 0 remwid)
    1072                       (cons width-remaining (cons* c char (cdr rest)))
    1073                       (cons (fx- remwid 1) (cons c (cdr rest))) ) ) )
    1074                 `(,width . ())
    1075                 result))))
    1076         ; Strip any leading comma char
    1077         (let ((1st-char (first result)))
    1078           (cond
    1079             ((char=? char 1st-char)
    1080               (cdr result))
    1081             ((or (char=? #\+ 1st-char) (char=? #\- 1st-char))
    1082               (if (and (not (null? (cdr result)))
    1083                        (char=? char (second result)))
    1084                 (cons 1st-char (cddr result))
    1085                 result))
    1086             (else
    1087               result) ) ) ) )
    1088     result) )
     1065      (let ((width-remaining (fx- width 1)))
     1066        (let ((result
     1067              (cdr
     1068                (fold-right
     1069                  (lambda (c rest)
     1070                    (let ((remwid (car rest)))
     1071                      (if (fx= 0 remwid)
     1072                          (cons width-remaining (cons* c char (cdr rest)))
     1073                          (cons (fx- remwid 1) (cons c (cdr rest))) ) ) )
     1074                  `(,width . ())
     1075                  result))))
     1076          ; Strip any leading comma char
     1077          (let ((1st-char (first result)))
     1078            (cond ((char=? char 1st-char)
     1079                    (cdr result))
     1080                  ((or (char=? #\+ 1st-char) (char=? #\- 1st-char))
     1081                    (if (and (not (null? (cdr result)))
     1082                             (char=? char (second result)))
     1083                        (cons 1st-char (cddr result))
     1084                        result))
     1085                  (else
     1086                    result) ) ) ) )
     1087      result) )
    10891088
    10901089;; Pull numbers from the argument list
     
    10991098  (let ((num (get-number state inc)))
    11001099    (if format:floats
    1101       (begin
    1102         (when (complex-strict? num)
    1103           (formatter-error "invalid one dimensional number" num) )
    1104         (exact->inexact num) )
    1105       (formatter-error "floating-point numbers unsupported" num) ) ) )
     1100        (begin
     1101          (when (complex-strict? num)
     1102            (formatter-error "invalid one dimensional number" num) )
     1103          (exact->inexact num) )
     1104        (formatter-error "floating-point numbers unsupported" num) ) ) )
    11061105
    11071106(define (get-complex state inc)
    11081107  (let ((num (get-number state inc)))
    11091108    (if format:complex
    1110       (if (complex-strict? num)
    1111         num
    1112         (make-rectangular (exact->inexact num) 0.0) )
    1113       (formatter-error "complex numbers unsupported" num) ) ) )
     1109        (if (complex-strict? num)
     1110            num
     1111            (make-rectangular (exact->inexact num) 0.0) )
     1112        (formatter-error "complex numbers unsupported" num) ) ) )
    11141113
    11151114; Given a number, return a list with the digits of its representation in the
     
    11201119  (let ((tail (string->list (number->string number base))))
    11211120    (if (and always-sign (not (negative? number)))
    1122       (cons #\+ tail)
    1123       tail)))
     1121        (cons #\+ tail)
     1122        tail)))
    11241123
    11251124(define (format-roman-old state num)
     
    11331132    (let loop ((ls *roman-numerals*))
    11341133      (let* ((big (car ls)) (big-n (car big)))
    1135         (cond
    1136           ((>= num big-n)
    1137            (*formatter-out-char state (cadr big))
    1138            (format-roman state (- num big-n)))
    1139           ((and (> (* 2 num) big-n)
    1140                 (find (compose (lambda (x) (<= (+ x 1) (- big-n x) num)) car) ls))
    1141            => (lambda (c)
    1142                 (*formatter-out-char state (cadr c))
    1143                 (*formatter-out-char state (cadr big))
    1144                 (format-roman state (- num (- big-n (car c))))))
    1145           (else (loop (cdr ls))))))))
     1134        (cond ((>= num big-n)
     1135               (*formatter-out-char state (cadr big))
     1136               (format-roman state (- num big-n)))
     1137              ((and (> (* 2 num) big-n)
     1138                    (find (compose (lambda (x) (<= (+ x 1) (- big-n x) num)) car) ls))
     1139               => (lambda (c)
     1140                    (*formatter-out-char state (cadr c))
     1141                    (*formatter-out-char state (cadr big))
     1142                    (format-roman state (- num (- big-n (car c))))))
     1143              (else (loop (cdr ls))))))))
    11461144
    11471145(define (format-number-english func zero)
    11481146  (lambda (state num)
    1149     (cond
    1150       ((not (integer? num)) (formatter-error "invalid integer" num))
    1151       ((zero? num) (*formatter-out-string state zero))
    1152       ((negative? num)
    1153        (*formatter-out-string state "minus ")
    1154        (func state (- num)))
    1155       (else (func state num)))))
     1147    (cond ((not (integer? num)) (formatter-error "invalid integer" num))
     1148          ((zero? num) (*formatter-out-string state zero))
     1149          ((negative? num)
     1150           (*formatter-out-string state "minus ")
     1151           (func state (- num)))
     1152          (else (func state num)))))
    11561153
    11571154;; Cardinal formatting
     
    11591156(define (initial-pows num pow)
    11601157  (if (zero? num)
    1161     '()
    1162     (cons (cons (remainder num 1000) pow)
    1163           (initial-pows (quotient num 1000) (+ pow 1)))))
     1158      '()
     1159      (cons (cons (remainder num 1000) pow)
     1160            (initial-pows (quotient num 1000) (+ pow 1)))))
    11641161
    11651162; Show a number between 0 and 20
     
    11711168
    11721169(define (format-cardinal-100 state num)
    1173   (cond
    1174     ((< num 20) (format-cardinal-20 state num))
    1175     (else
    1176       (*formatter-out-string state (vector-ref *cardinal-tens* (quotient num 10)))
    1177       (let ((ones (remainder num 10)))
    1178         (unless (zero? ones)
    1179           (unless (zero? (quotient num 10))
    1180             (*formatter-out-char state #\-))
    1181           (format-cardinal-20 state ones))))))
     1170  (cond ((< num 20)
     1171          (format-cardinal-20 state num))
     1172        (else
     1173          (*formatter-out-string state (vector-ref *cardinal-tens* (quotient num 10)))
     1174          (let ((ones (remainder num 10)))
     1175            (unless (zero? ones)
     1176              (unless (zero? (quotient num 10))
     1177                (*formatter-out-char state #\-))
     1178              (format-cardinal-20 state ones))))))
    11821179
    11831180; Show a number between 0 and 1000
     
    12141211
    12151212(define (format-ordinal-positive state num)
    1216   (cond
    1217     ((>= num 100)
    1218      (format-cardinal-positive state (* (quotient num 100) 100))
    1219      (let ((rest (remainder num 100)))
    1220        (unless (zero? rest)
    1221          (*formatter-out-char state #\space)
    1222          (format-ordinal-positive state rest))))
    1223     ((< num 20)
    1224       (format-ordinal-20 state num))
    1225     (else
    1226       (let ((tens (quotient num 10)) (ones (remainder num 10)))
    1227         (cond
    1228          ((zero? ones)
    1229           (*formatter-out-string state (vector-ref *ordinal-tens* tens)))
    1230          (else
    1231            (*formatter-out-string state (vector-ref *cardinal-tens* tens))
    1232            (*formatter-out-char state #\-)
    1233            (*formatter-out-string state (vector-ref *ordinal-ones* ones))))))))
     1213  (cond ((>= num 100)
     1214          (format-cardinal-positive state (* (quotient num 100) 100))
     1215          (let ((rest (remainder num 100)))
     1216            (unless (zero? rest)
     1217              (*formatter-out-char state #\space)
     1218              (format-ordinal-positive state rest))))
     1219        ((< num 20)
     1220          (format-ordinal-20 state num))
     1221        (else
     1222          (let ((tens (quotient num 10))
     1223                (ones (remainder num 10)))
     1224            (cond ((zero? ones)
     1225                    (*formatter-out-string state (vector-ref *ordinal-tens* tens)))
     1226                  (else
     1227                    (*formatter-out-string state (vector-ref *cardinal-tens* tens))
     1228                    (*formatter-out-char state #\-)
     1229                    (*formatter-out-string state (vector-ref *ordinal-ones* ones))))))))
    12341230
    12351231(define format-ordinal
     
    12481244
    12491245(define (formatter-radix state start params colon atsign)
    1250   (cond
    1251     ((not (null? params))
    1252      ((formatter-integer/radix (car params)) state start
    1253         (reverse (cdr params)) ; formatter-function reverses params so we must do it 1st
    1254         colon atsign))
    1255     (atsign
    1256      ((if colon format-roman-old format-roman) state (state-obj-ref state 1)))
    1257     (else
    1258      ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)))))
     1246  (cond ((not (null? params))
     1247         ((formatter-integer/radix (car params)) state start
     1248            (reverse (cdr params)) ; formatter-function reverses params so we must do it 1st
     1249            colon atsign))
     1250        (atsign
     1251         ((if colon format-roman-old format-roman) state (state-obj-ref state 1)))
     1252        (else
     1253         ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)))))
    12591254
    12601255;; Float formatting
     
    12721267(define (round-to-digits number width digits)
    12731268  (if (or width digits)
    1274     (let ((mult (expt 10 (or digits
    1275                              (- width
    1276                                 (if (zero? number) number (ceiling (log10 number)))
    1277                                 1)))))
    1278       (/ (round (* number mult)) mult))
    1279     number))
     1269      (let ((mult (expt 10 (or digits
     1270                               (- width
     1271                                  (if (zero? number) number (ceiling (log10 number)))
     1272                                  1)))))
     1273        (/ (round (* number mult)) mult))
     1274      number))
    12801275
    12811276; Given a positive fixed float number, return a list with the digits of its
     
    12891284         (middle
    12901285           (if dot
    1291              (string->list (substring str dot ((if digits (cute fxmin (fx+ dot (fx+ digits 1)) <>) identity) (string-length str))))
    1292              '(#\.)))
     1286               (string->list (substring str dot ((if digits (cute fxmin (fx+ dot (fx+ digits 1)) <>) identity) (string-length str))))
     1287               '(#\.)))
    12931288         (tail
    1294            (cond
    1295              (digits (make-list (fxmax 0 (fx- (fx- digits (length middle)) -1)) #\0))
    1296              (dot '())
    1297              (else '(#\0)))))
     1289           (cond (digits (make-list (fxmax 0 (fx- (fx- digits (length middle)) -1)) #\0))
     1290                 (dot '())
     1291                 (else '(#\0)))))
    12981292    (append
    12991293      (let ((result (string->list (if dot (substring str 0 dot) str))))
     
    13011295                 (fx= width (fx+ (fx+ (fx+ (length result) (if dot (- (string-length str) dot) 1)) (length tail)) -1))
    13021296                 (zero? (truncate number)))
    1303           (cdr result)
    1304           result))
     1297            (cdr result)
     1298            result))
    13051299      middle
    13061300      tail)))
     
    13131307(define (fixed-float-list number always-sign width digits)
    13141308  (if (or always-sign (negative? number))
    1315     (cons (if (negative? number) #\- #\+)
    1316           (fixed-float-list (abs number) #f (and width (fx- width 1)) digits))
    1317     (unsigned-fixed-float-list number width digits)) )
     1309      (cons (if (negative? number) #\- #\+)
     1310            (fixed-float-list (abs number) #f (and width (fx- width 1)) digits))
     1311      (unsigned-fixed-float-list number width digits)) )
    13181312
    13191313(define (exponential-float-list num always-sign width digits exp-digits scale overflow-ch exp-char)
     
    13271321             (and digits
    13281322                  (if (and scale (fx< 0 scale))
    1329                     (fx- (fx- digits scale) -1)
    1330                     digits)))))
     1323                      (fx- (fx- digits scale) -1)
     1324                      digits)))))
    13311325    (if (and exp-digits overflow-ch (< exp-digits (length expo-list)))
    1332       #f
    1333       (append
    1334         fixed
    1335         `(,exp-char)
    1336         (if (negative? expo) '(#\-) '(#\+))
    1337         (if (and exp-digits
    1338                  (or (not width)
    1339                      (fx<= (fx+ (fx+ (length fixed) 2) exp-digits) width)))
    1340           (make-list (fxmax 0 (fx- exp-digits (length expo-list))) #\0)
    1341           '())
    1342         expo-list))))
     1326        #f
     1327        (append
     1328          fixed
     1329          `(,exp-char)
     1330          (if (negative? expo) '(#\-) '(#\+))
     1331          (if (and exp-digits
     1332                   (or (not width)
     1333                       (fx<= (fx+ (fx+ (length fixed) 2) exp-digits) width)))
     1334              (make-list (fxmax 0 (fx- exp-digits (length expo-list))) #\0)
     1335              '())
     1336          expo-list))))
    13431337
    13441338; Given a positive fixed float number, return a list with the digits of its
     
    13551349      (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
    13561350    (if (and width overflow-ch (fx> len width))
    1357       (*formatter-out-char-times state width overflow-ch)
    1358       (*formatter-out-char-list state flt-res)) ) )
     1351        (*formatter-out-char-times state width overflow-ch)
     1352        (*formatter-out-char-list state flt-res)) ) )
    13591353
    13601354; Float formatters
     
    13641358    (let* ((result (exponential-float-list (get-float state 1) atsign width digits exp-digits scale overflow-ch exp-char))
    13651359           (len (and result (length result))))
    1366       (cond
    1367         ((or (not result) (and width overflow-ch (fx> len width)))
    1368          (*formatter-out-char-times state width overflow-ch))
    1369         (else
    1370           (when width
    1371             (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
    1372           (*formatter-out-char-list state result))))))
     1360      (cond ((or (not result) (and width overflow-ch (fx> len width)))
     1361             (*formatter-out-char-times state width overflow-ch))
     1362            (else
     1363              (when width
     1364                (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
     1365              (*formatter-out-char-list state result))))))
    13731366
    13741367(define (formatter-fixed-float state start params colon atsign)
     
    13851378           (d (or digits (max (string-length (number->string num)) (min n 7))))
    13861379           (dd (- d n)))
    1387       (cond
    1388         ((<= 0 dd d)
    1389          (formatter-fixed-float state start (list ww dd #f overflow-ch (or pad-char #\space)) colon atsign)
    1390          (tabulate state ee 1 #t (or pad-char #\space)))
    1391         (else
    1392           (formatter-exponential state start params colon atsign))))))
     1380      (cond ((<= 0 dd d)
     1381             (formatter-fixed-float state start (list ww dd #f overflow-ch (or pad-char #\space)) colon atsign)
     1382             (tabulate state ee 1 #t (or pad-char #\space)))
     1383            (else
     1384              (formatter-exponential state start params colon atsign))))))
    13931385
    13941386(define (formatter-dollar state start params colon atsign)
     
    14071399      ; Per CL spec, but probably never happen.
    14081400      (if (< (fxmax min-width 100) (fx- len (fx+ 1 sign-len)))
    1409         (formatter-exponential state start
    1410           (list min-width (fx+ digits-after (fx- min-digits-before 1)) #f #f #f pad-char)
    1411           colon atsign)
    1412         (begin
    1413           ; Sign before padding?
    1414           (when colon
    1415             (*formatter-out-char state sign))
    1416           ; Padding
    1417           (*formatter-out-char-times state
    1418             (fxmax 0 (fx- min-width (fx+ pad-zeros len))) (or pad-char #\space))
    1419           ; Sign after padding?
    1420           (when (and (not colon) sign)
    1421             (*formatter-out-char state sign))
    1422           ; Zero padding
    1423           (when (fx< 0 pad-zeros)
    1424             (*formatter-out-char-times state pad-zeros #\0))
    1425           (*formatter-out-char-list state result))) ) ) )
     1401          (formatter-exponential state start
     1402            (list min-width (fx+ digits-after (fx- min-digits-before 1)) #f #f #f pad-char)
     1403            colon atsign)
     1404          (begin
     1405            ; Sign before padding?
     1406            (when colon
     1407              (*formatter-out-char state sign))
     1408            ; Padding
     1409            (*formatter-out-char-times state
     1410              (fxmax 0 (fx- min-width (fx+ pad-zeros len))) (or pad-char #\space))
     1411            ; Sign after padding?
     1412            (when (and (not colon) sign)
     1413              (*formatter-out-char state sign))
     1414            ; Zero padding
     1415            (when (fx< 0 pad-zeros)
     1416              (*formatter-out-char-times state pad-zeros #\0))
     1417            (*formatter-out-char-list state result))) ) ) )
    14261418
    14271419(define (formatter-complex state start params colon atsign)
     
    15531545  (state-nest-push! state #\[)
    15541546  (state-condskip-push! state
    1555     (cond
    1556       ; If not on a valid state, use -1 so it will never become valid.
    1557       ((not (cond-valid? state)) -1)
    1558       (colon  (if (state-obj-ref state 1) 1 0))
    1559       (atsign (if (%state-obj-ref state) 0 (begin (state-objpos-inc! state 1) -1)))
    1560       ((null? params) (state-obj-ref state 1))
    1561       (else (car params)))))
     1547    (cond ((not (cond-valid? state)) -1) ; If not on a valid state, use -1 so it will never become valid.
     1548          (colon  (if (state-obj-ref state 1) 1 0))
     1549          (atsign (if (%state-obj-ref state) 0 (begin (state-objpos-inc! state 1) -1)))
     1550          ((null? params) (state-obj-ref state 1))
     1551          (else (car params)))))
    15621552
    15631553(define (formatter-cond-next state start params colon atsign)
     
    16221612;          extracts indirect arguments from format arguments.
    16231613; `~K'
    1624 ;      Same as `~?.'
     1614;      Same as `~?'.
    16251615
    16261616(define *formatter-indirection*
     
    16341624    (let-optionals params ((n (if atsign 0 1)))
    16351625      (if (and colon atsign)
    1636         (formatter-error "cannot specify both : and @ for ~*")
    1637         ((if atsign state-objpos-set! state-objpos-inc!)
    1638          state (if colon (- n) n)) ) ) ) )
     1626          (formatter-error "cannot specify both : and @ for ~*")
     1627          ((if atsign state-objpos-set! state-objpos-inc!)
     1628           state (if colon (- n) n)) ) ) ) )
    16391629
    16401630;`~*'
     
    16661656      (*formatter-out-string state "#\\")
    16671657      (let ((sym (char-name char)))
    1668         (cond
    1669           (sym
    1670             (*formatter-out-string state (symbol->string sym)))
    1671           ((char-set-contains? char-set:graphic char)
    1672             (*formatter-out-char state char))
    1673           (else
    1674             (let* ((str (number->string (char->integer char) 16))
    1675                    (strlen (string-length str)))
    1676               (let ((out-hex-char
    1677                     (lambda (prf wid)
    1678                       (*formatter-out-char state prf)
    1679                       (*formatter-out-char-times state (fx- wid strlen) #\0)
    1680                       (*formatter-out-string state str))))
    1681                 (cond
    1682                   ((fx<= strlen 2)  (out-hex-char #\x 2))
    1683                   ((fx<= strlen 4)  (out-hex-char #\u 4))
    1684                   (else             (out-hex-char #\U 8))) ) ) ) ) ) ) )
     1658        (cond (sym
     1659                (*formatter-out-string state (symbol->string sym)))
     1660              ((char-set-contains? char-set:graphic char)
     1661                (*formatter-out-char state char))
     1662              (else
     1663                (let* ((str (number->string (char->integer char) 16))
     1664                       (strlen (string-length str)))
     1665                  (let ((out-hex-char
     1666                        (lambda (prf wid)
     1667                          (*formatter-out-char state prf)
     1668                          (*formatter-out-char-times state (fx- wid strlen) #\0)
     1669                          (*formatter-out-string state str))))
     1670                    (cond ((fx<= strlen 2)  (out-hex-char #\x 2))
     1671                          ((fx<= strlen 4)  (out-hex-char #\u 4))
     1672                          (else             (out-hex-char #\U 8))) ) ) ) ) ) ) )
    16851673
    16861674  (else
     
    16961684(define (out-char-emacs state char)
    16971685  (let ((c (char->integer char)))
    1698     (cond
    1699       ((fx< c #x20) ; assumes that control chars are < #x20
    1700        (*formatter-out-char state #\^)
    1701        (*formatter-out-char state (integer->char (fx+ c #x40))))
    1702       ((fx>= c #x7f)
    1703        (*formatter-out-string state "#\\")
    1704        (*formatter-out-string state (number->string c 8)))
    1705       (else (*formatter-out-char state char)))))
     1686    (cond ((fx< c #x20) ; assumes that control chars are < #x20
     1687           (*formatter-out-char state #\^)
     1688           (*formatter-out-char state (integer->char (fx+ c #x40))))
     1689          ((fx>= c #x7f)
     1690           (*formatter-out-string state "#\\")
     1691           (*formatter-out-string state (number->string c 8)))
     1692          (else (*formatter-out-char state char)))))
    17061693
    17071694(define (formatter-char state start params colon atsign)
     
    17091696    (let ((char (state-obj-ref state 1)))
    17101697      (assert (char? char))
    1711       ((cond
    1712          (colon out-char-emacs)
    1713          (atsign out-char-lisp)
    1714          (else *formatter-out-char))
     1698      ((cond (colon out-char-emacs)
     1699             (atsign out-char-lisp)
     1700             (else *formatter-out-char))
    17151701       state
    17161702       char))))
     
    17201706(define (calc-padding n mincol colinc len)
    17211707  (if (fx< (fx+ len n) mincol)
    1722     (calc-padding (fx+ n colinc) mincol colinc len)
    1723     n))
     1708      (calc-padding (fx+ n colinc) mincol colinc len)
     1709      n))
    17241710
    17251711; Bind control character char to function show-func, used for displaying
     
    17851771  (*formatter-out-string state
    17861772    (if colon
    1787       "$Version: 1.7 $"
    1788       "Flexible Format Framework\n$Id: format-modular.scm 1.7 2007-06-08 12:00:00Z klovett $\n  Alejandro Forero Cuervo <azul@freaks-unidos.net>\n  Alex Shinn <foof@synthcode.com>\n  Kon Lovett <klovett@pacbell.net>\n")))
     1773        "$Version: 1.8 $"
     1774        "Flexible Format Framework\n$Id: format-modular.scm 1.8 2008-03-07 12:00:00Z klovett $\n  Alejandro Forero Cuervo <azul@freaks-unidos.net>\n  Alex Shinn <foof@synthcode.com>\n  Kon Lovett <klovett@pacbell.net>\n")))
    17891775
    17901776; `~Q'
     
    18581844; Supports the following escape sequences:
    18591845;
    1860 ; ?!P{}^()%/~|_XDOB[;]?*ASCRFEQGTY$I&
    1861 ;
    1862 ; And supports the following parameter sequences:
    1863 ;
    1864 ; V
     1846; ?!{}^()%/~|_[;]*$&IASCRFEQGTYPXDOBK
     1847;
     1848; And supports the following formatter parameter sequences:
     1849;
     1850; @:V#',+-0123456789
    18651851;
    18661852; The following are known to be missing:
     1853;
    18671854; <>
    18681855;
    18691856; The following are known to be incompatible:
     1857;
    18701858; /I
    18711859;
  • release/3/format-modular/trunk/format-modular.setup

    r4740 r9267  
    2121;See srfi-19.setup for a method of handling deeper directory bundles
    2222
    23 (compile -s -O2 -d1 format-modular-utf8.scm)
    24 
    2523(compile-dynld format-modular)
    2624(compile-static format-modular)
     25#;(compile-dynld format-modular-utf8.scm)
    2726(install-extension 'format-modular
    2827  '("format-modular.so" "format-modular.o"
    29     "format-modular-utf8.so")
    30   `((version ,(if (file-exists? "version") (with-input-from-file "version" read) "unknown"))
     28    #;"format-modular-utf8.so")
     29  `((version ,*version*)
    3130    (static "format-modular.o")
    3231    (documentation "format-modular.html")))
  • release/3/format-modular/trunk/tests/format-modular-test.scm

    r5099 r9267  
    203203(test '("~a" (a (b c) d)) "(a (b c) d)")
    204204(test '("~a" (a . b)) "(a . b)")
    205 (test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly
     205#; ; no it doesn't & why would it?
     206(test '("~a" (a (b c . d))) "(a (b . (c . d)))")
     207(test '("~a" (a (b c . d))) "(a (b c . d))")
    206208#; ; no internal object support
    207209(test `("~a" ,display) (formatter:iobj->str display #f))
     
    282284(test `("~@c" ,(integer->char 0)) "#\\nul")
    283285(test `("~@c" ,(integer->char 27)) "#\\esc")
     286#; ; not w/ Chicken
    284287(test `("~@c" ,(integer->char 127)) "#\\del")
     288(test `("~@c" ,(integer->char 127)) "#\\delete")
     289#; ; not w/ Chicken
    285290(test `("~@c" ,(integer->char 128)) "#\\200")
     291(test `("~@c" ,(integer->char 128)) "#\\x80")
    286292(test `("~@c" ,(integer->char 255)) "#\\377")
    287293#; ; character code unsupported
     
    323329
    324330")
     331; With Chicken this fails (until proper output port column counting)
    325332(test '("~&") "")
    326333(test '("abc~&") "abc
     
    353360(test '("~0&~3t") "   ")
    354361(test '("~0&~10t") "          ")
     362; Is this correct?
    355363(test '("~10t") "")
    356364(test '("~0&1234567890~,8tABC")  "1234567890       ABC")
     
    424432(test `("~s" ,slib:tab) "#\\ht")
    425433(test '("~s" #\a) "#\\a")
    426 (test '("~a" (a "b" c)) "(a \"b\" c)")
     434(test '("~s" (a "b" c)) "(a \"b\" c)")
    427435
    428436; flush output (can't test it here really)
     
    525533
    526534(test '("abc ~^ xyz") "abc ")
     535#; ; This is wrong
    527536(test '("~@(abc ~^ xyz~) ~a" 10) "ABC  xyz 10")
     537(test '("~@(abc ~^ xyz~) ~a" 10) "Abc  xyz 10")
    528538(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ")
    529539(test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done.  10 warnings. ")
     
    540550(test '("abc~3,7,5^ xyz") "abc xyz")
    541551
    542 #|
    543552; complexity tests (oh my god, I hardly understand them myself (see CL std))
    544553
     
    550559(test `(,fmt foo bar baz) "Items: foo, bar, and baz.")
    551560(test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.")
    552 |#
    553561
    554562; fixed floating points
Note: See TracChangeset for help on using the changeset viewer.