Changeset 9384 in project


Ignore:
Timestamp:
03/09/08 19:58:50 (12 years ago)
Author:
Kon Lovett
Message:

Added CL spec treatment of non-float.

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

Legend:

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

    r9268 r9384  
    2727; - W control support. Will subsume Y control. (See SRFI-38.)
    2828;
    29 ; - :^ control support.
     29; - ~:^ control support.
     30;
     31; - ~<...~> control support.
     32;
     33; - ~I control support.
    3034
    3135(require-extension (srfi 1) (srfi 9))
     
    6670          string->list
    6771          string-ref string-length
    68           string-map! string-copy string-index)
     72          string-map! string-copy string-index )
    6973        (no-procedure-checks-for-usual-bindings)
    7074        (import
    71           make-rectangular)
     75          make-rectangular )
    7276        (bound-to-procedure
    7377          make-rectangular
    7478          ; Forward declaration
    75           formatter-error start-iteration)
     79          formatter-error
     80          start-iteration
     81          format-string/padding )
    7682        (unused
    7783          state?
    78           iterator?)
     84          iterator? )
    7985        (export
    8086          ; Configuration Variables
     
    116122          ; format-functions.
    117123          formatter-padded
    118           formatter-function) ) )
     124          formatter-function ) ) )
    119125    (use srfi-13 srfi-14 lolevel)
    120126    (use srfi-29) )
     
    143149;(define format:en-max 10)
    144150(define format:expch #\E)
    145 ;(define format:radix-pref )
     151;(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
    146152;(define format:symbol-case-conv #f)
    147153;(define format:iobj-case-conv #f)
     
    10981104  (let ((num (get-number state inc)))
    10991105    (if format:floats
    1100         (begin
    1101           (when (complex-strict? num)
    1102             (formatter-error "invalid one dimensional number" num) )
    1103           (exact->inexact num) )
     1106        (if (complex-strict? num)
     1107            num
     1108            (exact->inexact num) )
    11041109        (formatter-error "floating-point numbers unsupported" num) ) ) )
    11051110
     
    12341239;; Integer formatting
    12351240
    1236 (define (formatter-integer/radix base)
     1241(define (formatter-integer/radix state start params colon atsign base)
     1242  (let-optionals params ((mincol 0) (pad-char #\space) (commachar #\,) (commawidth 3))
     1243    (let ((num (get-number state 1)))
     1244      (if (integer? num)
     1245          (let ((result (add-comma (and colon (or commachar #\,)) (or commawidth 3) (number-list num atsign base))))
     1246            (*formatter-out-char-times state (fxmax 0 (fx- (or mincol 0) (length result))) (or pad-char #\space))
     1247            (*formatter-out-char-list state result) )
     1248          ; This ignores the radix but the CL spec isn't clear on this except for ~D
     1249          (format-string/padding (with-output-to-string (lambda () (display num))) state colon atsign mincol #f #f pad-char) ) ) ) )
     1250
     1251(define (make-formatter-integer/radix base)
    12371252  (formatter-function
    12381253    (lambda (state start params colon atsign)
    1239       (let-optionals params ((mincol 0) (pad-char #\space) (commachar #\,) (commawidth 3))
    1240         (let ((result (add-comma (and colon (or commachar #\,)) (or commawidth 3)
    1241                                  (number-list (get-number state 1) atsign base))))
    1242           (*formatter-out-char-times state (fxmax 0 (fx- (or mincol 0) (length result))) (or pad-char #\space))
    1243           (*formatter-out-char-list state result))))))
     1254      (formatter-integer/radix state start params colon atsign base) ) ) )
    12441255
    12451256(define (formatter-radix state start params colon atsign)
    12461257  (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))
     1258         (formatter-integer/radix state start (cdr params) colon atsign (car params)) )
    12501259        (atsign
    1251          ((if colon format-roman-old format-roman) state (state-obj-ref state 1)))
     1260         ((if colon format-roman-old format-roman) state (state-obj-ref state 1)) )
    12521261        (else
    1253          ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)))))
     1262         ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)) ) ) )
    12541263
    12551264;; Float formatting
     
    13521361        (*formatter-out-char-list state flt-res)) ) )
    13531362
     1363; Treat a non-float per CL spec. (~D which is just ~A w/ base 10)
     1364
     1365(define (format-non-float num state colon atsign pad-char)
     1366  (format-string/padding (with-output-to-string (lambda () (display num)))
     1367                         state colon atsign #f #f #f pad-char) )
     1368
    13541369; Float formatters
    13551370
    13561371(define (formatter-exponential state start params colon atsign)
    13571372  (let-optionals params ((width #f) (digits #f) (exp-digits #f) (scale #f) (overflow-ch #f) (pad-char #f) (exp-char format:expch))
    1358     (let* ((result (exponential-float-list (get-float state 1) atsign width digits exp-digits scale overflow-ch exp-char))
    1359            (len (and result (length 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))))))
     1373    (let ((num (get-float state 1)))
     1374      (if (complex-strict? num)
     1375          (format-non-float num state colon atsign pad-char)
     1376          (let* ((result (exponential-float-list num atsign width digits exp-digits scale overflow-ch exp-char))
     1377                 (len (and result (length result))))
     1378            (cond ((or (not result) (and width overflow-ch (fx> len width)))
     1379                   (*formatter-out-char-times state width overflow-ch) )
     1380                  (else
     1381                    (when width
     1382                      (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
     1383                    (*formatter-out-char-list state result) ) ) ) ) ) ) )
    13661384
    13671385(define (formatter-fixed-float state start params colon atsign)
    13681386  (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
    1369     (out-fixed-float-list state width overflow-ch pad-char
    1370       (fixed-float-list (* (get-float state 1) (expt 10 (or scale 0))) atsign width digits)) ) )
     1387    (let ((num (get-float state 1)))
     1388      (if (complex-strict? num)
     1389          (format-non-float num state colon atsign pad-char)
     1390          (out-fixed-float-list state width overflow-ch pad-char
     1391            (fixed-float-list (* num (expt 10 (or scale 0))) atsign width digits)) ) ) ) )
    13711392
    13721393(define (formatter-general-float state start params colon atsign)
    13731394  (let-optionals params ((width #f) (digits #f) (exp-digits #f) (scale 1) (overflow-ch #f) (pad-char #f) (exp-ch format:expch))
    1374     (let* ((num (get-float state 0))
    1375            (n (if (zero? num) 0 (inexact->exact (ceiling (log10 num)))))
    1376            (ee (if exp-digits (fx+ 2 exp-digits) 4))
    1377            (ww (and width (fx- width ee)))
    1378            (d (or digits (max (string-length (number->string num)) (min n 7))))
    1379            (dd (- d n)))
    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))))))
     1395    (let ((num (get-float state 0)))
     1396      (if (complex-strict? num)
     1397          (format-non-float num state colon atsign pad-char)
     1398          (let* ((n (if (zero? num) 0 (inexact->exact (ceiling (log10 num)))))
     1399                 (ee (if exp-digits (fx+ 2 exp-digits) 4))
     1400                 (ww (and width (fx- width ee)))
     1401                 (d (or digits (max (string-length (number->string num)) (min n 7))))
     1402                 (dd (- d n)))
     1403            (cond ((<= 0 dd d)
     1404                   (formatter-fixed-float state start (list ww dd #f overflow-ch (or pad-char #\space)) colon atsign)
     1405                   (tabulate state ee 1 #t (or pad-char #\space)) )
     1406                  (else
     1407                    (formatter-exponential state start params colon atsign) ) ) ) ) ) ) )
    13851408
    13861409(define (formatter-dollar state start params colon atsign)
    13871410  (let-optionals params ((digits-after #f) (min-digits-before #f) (min-width #f) (pad-char #f))
    1388     (let* ((digits-after (or digits-after 2))
    1389            (min-digits-before (or min-digits-before 1))
    1390            (min-width (or min-width 0))
    1391            (pad-char (or pad-char #\space))
    1392            (num (get-float state 1))
    1393            (sign (if (negative? num) #\- (and atsign #\+)))
    1394            (sign-len (if sign 1 0))
    1395            (result (fixed-dollar-list num min-digits-before digits-after))
    1396            (len (fx+ (length result) sign-len))
    1397            (leading-digits (list-index (cut char=? #\. <>) result))
    1398            (pad-zeros (fxmax 0 (fx- min-digits-before (or leading-digits 0)))) )
    1399       ; Per CL spec, but probably never happen.
    1400       (if (< (fxmax min-width 100) (fx- len (fx+ 1 sign-len)))
    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))) ) ) )
     1411    (let ((num (get-float state 1)))
     1412      (if (complex-strict? num)
     1413          (format-non-float num state colon atsign pad-char)
     1414          (let* ((digits-after (or digits-after 2))
     1415                 (min-digits-before (or min-digits-before 1))
     1416                 (min-width (or min-width 0))
     1417                 (pad-char (or pad-char #\space))
     1418                 (sign (if (negative? num) #\- (and atsign #\+)))
     1419                 (sign-len (if sign 1 0))
     1420                 (result (fixed-dollar-list num min-digits-before digits-after))
     1421                 (len (fx+ (length result) sign-len))
     1422                 (leading-digits (list-index (cut char=? #\. <>) result))
     1423                 (pad-zeros (fxmax 0 (fx- min-digits-before (or leading-digits 0)))) )
     1424            ; Per CL spec, but probably never happen.
     1425            (if (< (fxmax min-width 100) (fx- len (fx+ 1 sign-len)))
     1426                (formatter-exponential state start
     1427                  (list min-width (fx+ digits-after (fx- min-digits-before 1)) #f #f #f pad-char)
     1428                  colon atsign)
     1429                (begin
     1430                  ; Sign before padding?
     1431                  (when colon
     1432                    (*formatter-out-char state sign))
     1433                  ; Padding
     1434                  (*formatter-out-char-times state
     1435                    (fxmax 0 (fx- min-width (fx+ pad-zeros len))) (or pad-char #\space))
     1436                  ; Sign after padding?
     1437                  (when (and (not colon) sign)
     1438                    (*formatter-out-char state sign))
     1439                  ; Zero padding
     1440                  (when (fx< 0 pad-zeros)
     1441                    (*formatter-out-char-times state pad-zeros #\0))
     1442                  (*formatter-out-char-list state result))) ) ) ) ) )
    14181443
    14191444(define (formatter-complex state start params colon atsign)
    14201445  (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
    1421     (let ((z (get-complex state 1)))
     1446    (let ((z (get-complex state 1))
     1447          (scale-factor (expt 10 (or scale 0))))
    14221448      (out-fixed-float-list state width overflow-ch pad-char
    1423         (fixed-float-list (* (real-part z) (expt 10 (or scale 0))) atsign width digits))
     1449        (fixed-float-list (* (real-part z) scale-factor) atsign width digits))
    14241450      (out-fixed-float-list state width overflow-ch pad-char
    1425         (fixed-float-list (* (imag-part z) (expt 10 (or scale 0))) #t width digits))
     1451        (fixed-float-list (* (imag-part z) scale-factor) #t width digits))
    14261452      (*formatter-out-char state #\i) ) ) )
    14271453
     
    14941520;           If the number is positive a plus sign is printed.
    14951521;
    1496 ;
    14971522; `~E'
    14981523;      Exponential floating-point (prints a flonum like MMM.NNN`E'EE).
     
    15301555(define *formatter-numbers*
    15311556  `((#\R ,(formatter-function formatter-radix))
    1532     (#\X ,(formatter-integer/radix 16))
    1533     (#\D ,(formatter-integer/radix 10))
    1534     (#\O ,(formatter-integer/radix 8))
    1535     (#\B ,(formatter-integer/radix 2))
     1557    (#\X ,(make-formatter-integer/radix 16))
     1558    (#\D ,(make-formatter-integer/radix 10))
     1559    (#\O ,(make-formatter-integer/radix 8))
     1560    (#\B ,(make-formatter-integer/radix 2))
    15361561    (#\G ,(formatter-function formatter-general-float))
    15371562    (#\F ,(formatter-function formatter-fixed-float))
     
    17171742; colon causes stringification
    17181743
     1744(define (format-string/padding objstr state colon atsign mincol colinc minpad pad-char)
     1745  (unless atsign (*formatter-out-string state objstr))
     1746  (*formatter-out-char-times state (calc-padding (or minpad 0) (or mincol 0) (or colinc 1) (string-length objstr)) (or pad-char #\space))
     1747  (when atsign (*formatter-out-string state objstr)) )
     1748
    17191749(define (formatter-padded show-func)
    17201750  (formatter-function
    17211751    (lambda (state start params colon atsign)
    17221752      (let-optionals params ((mincol 0) (colinc 1) (minpad 0) (pad-char #\space))
    1723         (let ((objstr (with-output-to-string (lambda () (show-func (state-obj-ref state 1))))))
    1724           (unless atsign (*formatter-out-string state objstr))
    1725           (*formatter-out-char-times state (calc-padding (or minpad 0) (or mincol 0) (or colinc 1) (string-length objstr)) (or pad-char #\space))
    1726           (when atsign (*formatter-out-string state objstr)))))))
     1753        (format-string/padding (with-output-to-string (lambda () (show-func (state-obj-ref state 1)))) state colon atsign mincol colinc minpad pad-char) ) ) ) )
    17271754
    17281755(define (formatter-pretty-print)
     
    17611788
    17621789(define *formatter-objs*
    1763   `((#\A ,(formatter-padded display))
     1790  `((#\C ,formatter-char)
     1791    (#\A ,(formatter-padded display))
    17641792    (#\S ,(formatter-padded write))
    1765     (#\Y ,(formatter-pretty-print))
    1766     (#\C ,formatter-char)))
     1793    (#\Y ,(formatter-pretty-print))))
    17671794
    17681795;;; Version info
     
    18521879; The following are known to be missing:
    18531880;
    1854 ; <>
     1881; <> :^
    18551882;
    18561883; The following are known to be incompatible:
  • release/3/format-modular/tags/1.8/tests/format-modular-test.scm

    r9268 r9384  
    684684"*********|?????????|%%%%%%%%%|3.14E+120")
    685685
    686 (test '("~g" 0.0) "0.0    ")            ; further ~g tests
     686; further ~g tests
     687(test '("~g" 0.0) "0.0    ")
    687688(test '("~g" 0.1) "0.1    ")
    688689(test '("~g" 0.01) "1.0E-2")
  • release/3/format-modular/trunk/format-modular.scm

    r9267 r9384  
    2727; - W control support. Will subsume Y control. (See SRFI-38.)
    2828;
    29 ; - :^ control support.
     29; - ~:^ control support.
     30;
     31; - ~<...~> control support.
     32;
     33; - ~I control support.
    3034
    3135(require-extension (srfi 1) (srfi 9))
     
    6670          string->list
    6771          string-ref string-length
    68           string-map! string-copy string-index)
     72          string-map! string-copy string-index )
    6973        (no-procedure-checks-for-usual-bindings)
    7074        (import
    71           make-rectangular)
     75          make-rectangular )
    7276        (bound-to-procedure
    7377          make-rectangular
    7478          ; Forward declaration
    75           formatter-error start-iteration)
     79          formatter-error
     80          start-iteration
     81          format-string/padding )
    7682        (unused
    7783          state?
    78           iterator?)
     84          iterator? )
    7985        (export
    8086          ; Configuration Variables
     
    116122          ; format-functions.
    117123          formatter-padded
    118           formatter-function) ) )
     124          formatter-function ) ) )
    119125    (use srfi-13 srfi-14 lolevel)
    120126    (use srfi-29) )
     
    143149;(define format:en-max 10)
    144150(define format:expch #\E)
    145 ;(define format:radix-pref )
     151;(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
    146152;(define format:symbol-case-conv #f)
    147153;(define format:iobj-case-conv #f)
     
    10981104  (let ((num (get-number state inc)))
    10991105    (if format:floats
    1100         (begin
    1101           (when (complex-strict? num)
    1102             (formatter-error "invalid one dimensional number" num) )
    1103           (exact->inexact num) )
     1106        (if (complex-strict? num)
     1107            num
     1108            (exact->inexact num) )
    11041109        (formatter-error "floating-point numbers unsupported" num) ) ) )
    11051110
     
    12341239;; Integer formatting
    12351240
    1236 (define (formatter-integer/radix base)
     1241(define (formatter-integer/radix state start params colon atsign base)
     1242  (let-optionals params ((mincol 0) (pad-char #\space) (commachar #\,) (commawidth 3))
     1243    (let ((num (get-number state 1)))
     1244      (if (integer? num)
     1245          (let ((result (add-comma (and colon (or commachar #\,)) (or commawidth 3) (number-list num atsign base))))
     1246            (*formatter-out-char-times state (fxmax 0 (fx- (or mincol 0) (length result))) (or pad-char #\space))
     1247            (*formatter-out-char-list state result) )
     1248          ; This ignores the radix but the CL spec isn't clear on this except for ~D
     1249          (format-string/padding (with-output-to-string (lambda () (display num))) state colon atsign mincol #f #f pad-char) ) ) ) )
     1250
     1251(define (make-formatter-integer/radix base)
    12371252  (formatter-function
    12381253    (lambda (state start params colon atsign)
    1239       (let-optionals params ((mincol 0) (pad-char #\space) (commachar #\,) (commawidth 3))
    1240         (let ((result (add-comma (and colon (or commachar #\,)) (or commawidth 3)
    1241                                  (number-list (get-number state 1) atsign base))))
    1242           (*formatter-out-char-times state (fxmax 0 (fx- (or mincol 0) (length result))) (or pad-char #\space))
    1243           (*formatter-out-char-list state result))))))
     1254      (formatter-integer/radix state start params colon atsign base) ) ) )
    12441255
    12451256(define (formatter-radix state start params colon atsign)
    12461257  (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))
     1258         (formatter-integer/radix state start (cdr params) colon atsign (car params)) )
    12501259        (atsign
    1251          ((if colon format-roman-old format-roman) state (state-obj-ref state 1)))
     1260         ((if colon format-roman-old format-roman) state (state-obj-ref state 1)) )
    12521261        (else
    1253          ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)))))
     1262         ((if colon format-ordinal format-cardinal) state (state-obj-ref state 1)) ) ) )
    12541263
    12551264;; Float formatting
     
    13521361        (*formatter-out-char-list state flt-res)) ) )
    13531362
     1363; Treat a non-float per CL spec. (~D which is just ~A w/ base 10)
     1364
     1365(define (format-non-float num state colon atsign pad-char)
     1366  (format-string/padding (with-output-to-string (lambda () (display num)))
     1367                         state colon atsign #f #f #f pad-char) )
     1368
    13541369; Float formatters
    13551370
    13561371(define (formatter-exponential state start params colon atsign)
    13571372  (let-optionals params ((width #f) (digits #f) (exp-digits #f) (scale #f) (overflow-ch #f) (pad-char #f) (exp-char format:expch))
    1358     (let* ((result (exponential-float-list (get-float state 1) atsign width digits exp-digits scale overflow-ch exp-char))
    1359            (len (and result (length 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))))))
     1373    (let ((num (get-float state 1)))
     1374      (if (complex-strict? num)
     1375          (format-non-float num state colon atsign pad-char)
     1376          (let* ((result (exponential-float-list num atsign width digits exp-digits scale overflow-ch exp-char))
     1377                 (len (and result (length result))))
     1378            (cond ((or (not result) (and width overflow-ch (fx> len width)))
     1379                   (*formatter-out-char-times state width overflow-ch) )
     1380                  (else
     1381                    (when width
     1382                      (*formatter-out-char-times state (fxmax 0 (fx- width len)) (or pad-char #\space)))
     1383                    (*formatter-out-char-list state result) ) ) ) ) ) ) )
    13661384
    13671385(define (formatter-fixed-float state start params colon atsign)
    13681386  (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
    1369     (out-fixed-float-list state width overflow-ch pad-char
    1370       (fixed-float-list (* (get-float state 1) (expt 10 (or scale 0))) atsign width digits)) ) )
     1387    (let ((num (get-float state 1)))
     1388      (if (complex-strict? num)
     1389          (format-non-float num state colon atsign pad-char)
     1390          (out-fixed-float-list state width overflow-ch pad-char
     1391            (fixed-float-list (* num (expt 10 (or scale 0))) atsign width digits)) ) ) ) )
    13711392
    13721393(define (formatter-general-float state start params colon atsign)
    13731394  (let-optionals params ((width #f) (digits #f) (exp-digits #f) (scale 1) (overflow-ch #f) (pad-char #f) (exp-ch format:expch))
    1374     (let* ((num (get-float state 0))
    1375            (n (if (zero? num) 0 (inexact->exact (ceiling (log10 num)))))
    1376            (ee (if exp-digits (fx+ 2 exp-digits) 4))
    1377            (ww (and width (fx- width ee)))
    1378            (d (or digits (max (string-length (number->string num)) (min n 7))))
    1379            (dd (- d n)))
    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))))))
     1395    (let ((num (get-float state 0)))
     1396      (if (complex-strict? num)
     1397          (format-non-float num state colon atsign pad-char)
     1398          (let* ((n (if (zero? num) 0 (inexact->exact (ceiling (log10 num)))))
     1399                 (ee (if exp-digits (fx+ 2 exp-digits) 4))
     1400                 (ww (and width (fx- width ee)))
     1401                 (d (or digits (max (string-length (number->string num)) (min n 7))))
     1402                 (dd (- d n)))
     1403            (cond ((<= 0 dd d)
     1404                   (formatter-fixed-float state start (list ww dd #f overflow-ch (or pad-char #\space)) colon atsign)
     1405                   (tabulate state ee 1 #t (or pad-char #\space)) )
     1406                  (else
     1407                    (formatter-exponential state start params colon atsign) ) ) ) ) ) ) )
    13851408
    13861409(define (formatter-dollar state start params colon atsign)
    13871410  (let-optionals params ((digits-after #f) (min-digits-before #f) (min-width #f) (pad-char #f))
    1388     (let* ((digits-after (or digits-after 2))
    1389            (min-digits-before (or min-digits-before 1))
    1390            (min-width (or min-width 0))
    1391            (pad-char (or pad-char #\space))
    1392            (num (get-float state 1))
    1393            (sign (if (negative? num) #\- (and atsign #\+)))
    1394            (sign-len (if sign 1 0))
    1395            (result (fixed-dollar-list num min-digits-before digits-after))
    1396            (len (fx+ (length result) sign-len))
    1397            (leading-digits (list-index (cut char=? #\. <>) result))
    1398            (pad-zeros (fxmax 0 (fx- min-digits-before (or leading-digits 0)))) )
    1399       ; Per CL spec, but probably never happen.
    1400       (if (< (fxmax min-width 100) (fx- len (fx+ 1 sign-len)))
    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))) ) ) )
     1411    (let ((num (get-float state 1)))
     1412      (if (complex-strict? num)
     1413          (format-non-float num state colon atsign pad-char)
     1414          (let* ((digits-after (or digits-after 2))
     1415                 (min-digits-before (or min-digits-before 1))
     1416                 (min-width (or min-width 0))
     1417                 (pad-char (or pad-char #\space))
     1418                 (sign (if (negative? num) #\- (and atsign #\+)))
     1419                 (sign-len (if sign 1 0))
     1420                 (result (fixed-dollar-list num min-digits-before digits-after))
     1421                 (len (fx+ (length result) sign-len))
     1422                 (leading-digits (list-index (cut char=? #\. <>) result))
     1423                 (pad-zeros (fxmax 0 (fx- min-digits-before (or leading-digits 0)))) )
     1424            ; Per CL spec, but probably never happen.
     1425            (if (< (fxmax min-width 100) (fx- len (fx+ 1 sign-len)))
     1426                (formatter-exponential state start
     1427                  (list min-width (fx+ digits-after (fx- min-digits-before 1)) #f #f #f pad-char)
     1428                  colon atsign)
     1429                (begin
     1430                  ; Sign before padding?
     1431                  (when colon
     1432                    (*formatter-out-char state sign))
     1433                  ; Padding
     1434                  (*formatter-out-char-times state
     1435                    (fxmax 0 (fx- min-width (fx+ pad-zeros len))) (or pad-char #\space))
     1436                  ; Sign after padding?
     1437                  (when (and (not colon) sign)
     1438                    (*formatter-out-char state sign))
     1439                  ; Zero padding
     1440                  (when (fx< 0 pad-zeros)
     1441                    (*formatter-out-char-times state pad-zeros #\0))
     1442                  (*formatter-out-char-list state result))) ) ) ) ) )
    14181443
    14191444(define (formatter-complex state start params colon atsign)
    14201445  (let-optionals params ((width #f) (digits #f) (scale #f) (overflow-ch #f) (pad-char #f))
    1421     (let ((z (get-complex state 1)))
     1446    (let ((z (get-complex state 1))
     1447          (scale-factor (expt 10 (or scale 0))))
    14221448      (out-fixed-float-list state width overflow-ch pad-char
    1423         (fixed-float-list (* (real-part z) (expt 10 (or scale 0))) atsign width digits))
     1449        (fixed-float-list (* (real-part z) scale-factor) atsign width digits))
    14241450      (out-fixed-float-list state width overflow-ch pad-char
    1425         (fixed-float-list (* (imag-part z) (expt 10 (or scale 0))) #t width digits))
     1451        (fixed-float-list (* (imag-part z) scale-factor) #t width digits))
    14261452      (*formatter-out-char state #\i) ) ) )
    14271453
     
    14941520;           If the number is positive a plus sign is printed.
    14951521;
    1496 ;
    14971522; `~E'
    14981523;      Exponential floating-point (prints a flonum like MMM.NNN`E'EE).
     
    15301555(define *formatter-numbers*
    15311556  `((#\R ,(formatter-function formatter-radix))
    1532     (#\X ,(formatter-integer/radix 16))
    1533     (#\D ,(formatter-integer/radix 10))
    1534     (#\O ,(formatter-integer/radix 8))
    1535     (#\B ,(formatter-integer/radix 2))
     1557    (#\X ,(make-formatter-integer/radix 16))
     1558    (#\D ,(make-formatter-integer/radix 10))
     1559    (#\O ,(make-formatter-integer/radix 8))
     1560    (#\B ,(make-formatter-integer/radix 2))
    15361561    (#\G ,(formatter-function formatter-general-float))
    15371562    (#\F ,(formatter-function formatter-fixed-float))
     
    17171742; colon causes stringification
    17181743
     1744(define (format-string/padding objstr state colon atsign mincol colinc minpad pad-char)
     1745  (unless atsign (*formatter-out-string state objstr))
     1746  (*formatter-out-char-times state (calc-padding (or minpad 0) (or mincol 0) (or colinc 1) (string-length objstr)) (or pad-char #\space))
     1747  (when atsign (*formatter-out-string state objstr)) )
     1748
    17191749(define (formatter-padded show-func)
    17201750  (formatter-function
    17211751    (lambda (state start params colon atsign)
    17221752      (let-optionals params ((mincol 0) (colinc 1) (minpad 0) (pad-char #\space))
    1723         (let ((objstr (with-output-to-string (lambda () (show-func (state-obj-ref state 1))))))
    1724           (unless atsign (*formatter-out-string state objstr))
    1725           (*formatter-out-char-times state (calc-padding (or minpad 0) (or mincol 0) (or colinc 1) (string-length objstr)) (or pad-char #\space))
    1726           (when atsign (*formatter-out-string state objstr)))))))
     1753        (format-string/padding (with-output-to-string (lambda () (show-func (state-obj-ref state 1)))) state colon atsign mincol colinc minpad pad-char) ) ) ) )
    17271754
    17281755(define (formatter-pretty-print)
     
    17611788
    17621789(define *formatter-objs*
    1763   `((#\A ,(formatter-padded display))
     1790  `((#\C ,formatter-char)
     1791    (#\A ,(formatter-padded display))
    17641792    (#\S ,(formatter-padded write))
    1765     (#\Y ,(formatter-pretty-print))
    1766     (#\C ,formatter-char)))
     1793    (#\Y ,(formatter-pretty-print))))
    17671794
    17681795;;; Version info
     
    18521879; The following are known to be missing:
    18531880;
    1854 ; <>
     1881; <> :^
    18551882;
    18561883; The following are known to be incompatible:
  • release/3/format-modular/trunk/tests/format-modular-test.scm

    r9267 r9384  
    684684"*********|?????????|%%%%%%%%%|3.14E+120")
    685685
    686 (test '("~g" 0.0) "0.0    ")            ; further ~g tests
     686; further ~g tests
     687(test '("~g" 0.0) "0.0    ")
    687688(test '("~g" 0.1) "0.1    ")
    688689(test '("~g" 0.01) "1.0E-2")
Note: See TracChangeset for help on using the changeset viewer.