/[guile]/guile/guile-core/ice-9/format.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/format.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by mvo, Wed May 8 20:00:59 2002 UTC revision 1.15 by mvo, Thu May 9 19:37:37 2002 UTC
# Line 1203  Line 1203 
1203                                  (list-ref format:ordinal-ones-list ones))))                                  (list-ref format:ordinal-ones-list ones))))
1204                          ))))))))                          ))))))))
1205    
1206    ;; format inf and nan.
1207    
1208    (define (format:out-inf-nan number width digits edigits overch padch)
1209      ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
1210      ;; "+nan.0", suitably justified in their field.  We insist on
1211      ;; printing this exact form so that the numbers can be read back in.
1212    
1213      (let* ((str (number->string number))
1214             (len (string-length str))
1215             (dot (string-index str #\.))
1216             (digits (+ (or digits 0)
1217                        (if edigits (+ edigits 2) 0))))
1218        (if (and width overch (< width len))
1219            (format:out-fill width (integer->char overch))
1220            (let* ((leftpad (if width
1221                                (max (- width (max len (+ dot 1 digits))) 0)
1222                                0))
1223                   (rightpad (if width
1224                                 (max (- width leftpad len) 0)
1225                                 0))
1226                   (padch (integer->char (or padch format:space-ch))))
1227              (format:out-fill leftpad padch)
1228              (format:out-str str)
1229              (format:out-fill rightpad padch)))))
1230    
1231  ;; format fixed flonums (~F)  ;; format fixed flonums (~F)
1232    
1233  (define (format:out-fixed modifier number pars)  (define (format:out-fixed modifier number pars)
# Line 1216  Line 1241 
1241            (overch (format:par pars l 3 #f #f))            (overch (format:par pars l 3 #f #f))
1242            (padch (format:par pars l 4 format:space-ch #f)))            (padch (format:par pars l 4 format:space-ch #f)))
1243    
1244      (if digits      (cond
1245         ((or (inf? number) (nan? number))
1246          (begin                          ; fixed precision        (format:out-inf-nan number width digits #f overch padch))
1247            (format:parse-float  
1248             (if (string? number) number (number->string number)) #t scale)       (digits
1249            (if (<= (- format:fn-len format:fn-dot) digits)        (format:parse-float
1250                (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))         (if (string? number) number (number->string number)) #t scale)
1251                (format:fn-round digits))        (if (<= (- format:fn-len format:fn-dot) digits)
1252            (if width            (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
1253                (let ((numlen (+ format:fn-len 1)))            (format:fn-round digits))
1254                  (if (or (not format:fn-pos?) (eq? modifier 'at))        (if width
1255                      (set! numlen (+ numlen 1)))            (let ((numlen (+ format:fn-len 1)))
1256                  (if (and (= format:fn-dot 0) (> width (+ digits 1)))              (if (or (not format:fn-pos?) (eq? modifier 'at))
1257                      (set! numlen (+ numlen 1)))                  (set! numlen (+ numlen 1)))
1258                  (if (< numlen width)              (if (and (= format:fn-dot 0) (> width (+ digits 1)))
1259                      (format:out-fill (- width numlen) (integer->char padch)))                  (set! numlen (+ numlen 1)))
1260                  (if (and overch (> numlen width))              (if (< numlen width)
1261                      (format:out-fill width (integer->char overch))                  (format:out-fill (- width numlen) (integer->char padch)))
1262                      (format:fn-out modifier (> width (+ digits 1)))))              (if (and overch (> numlen width))
1263                (format:fn-out modifier #t)))                  (format:out-fill width (integer->char overch))
1264                    (format:fn-out modifier (> width (+ digits 1)))))
1265          (begin                          ; free precision            (format:fn-out modifier #t)))
1266            (format:parse-float  
1267             (if (string? number) number (number->string number)) #t scale)       (else
1268            (format:fn-strip)        (format:parse-float
1269            (if width         (if (string? number) number (number->string number)) #t scale)
1270                (let ((numlen (+ format:fn-len 1)))        (format:fn-strip)
1271                  (if (or (not format:fn-pos?) (eq? modifier 'at))        (if width
1272                      (set! numlen (+ numlen 1)))            (let ((numlen (+ format:fn-len 1)))
1273                  (if (= format:fn-dot 0)              (if (or (not format:fn-pos?) (eq? modifier 'at))
1274                      (set! numlen (+ numlen 1)))                  (set! numlen (+ numlen 1)))
1275                  (if (< numlen width)              (if (= format:fn-dot 0)
1276                      (format:out-fill (- width numlen) (integer->char padch)))                  (set! numlen (+ numlen 1)))
1277                  (if (> numlen width)    ; adjust precision if possible              (if (< numlen width)
1278                      (let ((dot-index (- numlen                  (format:out-fill (- width numlen) (integer->char padch)))
1279                                          (- format:fn-len format:fn-dot))))              (if (> numlen width)        ; adjust precision if possible
1280                        (if (> dot-index width)                  (let ((dot-index (- numlen
1281                            (if overch    ; numstr too big for required width                                      (- format:fn-len format:fn-dot))))
1282                                (format:out-fill width (integer->char overch))                    (if (> dot-index width)
1283                                (format:fn-out modifier #t))                        (if overch        ; numstr too big for required width
1284                            (begin                            (format:out-fill width (integer->char overch))
1285                              (format:fn-round (- width dot-index))                            (format:fn-out modifier #t))
1286                              (format:fn-out modifier #t))))                        (begin
1287                      (format:fn-out modifier #t)))                          (format:fn-round (- width dot-index))
1288                (format:fn-out modifier #t)))))))                          (format:fn-out modifier #t))))
1289                    (format:fn-out modifier #t)))
1290              (format:fn-out modifier #t)))))))
1291    
1292  ;; format exponential flonums (~E)  ;; format exponential flonums (~E)
1293    
# Line 1276  Line 1303 
1303            (overch (format:par pars l 4 #f #f))            (overch (format:par pars l 4 #f #f))
1304            (padch (format:par pars l 5 format:space-ch #f))            (padch (format:par pars l 5 format:space-ch #f))
1305            (expch (format:par pars l 6 #f #f)))            (expch (format:par pars l 6 #f #f)))
1306                    
1307      (if digits                          ; fixed precision        (cond
1308           ((or (inf? number) (nan? number))
1309            (format:out-inf-nan number width digits edigits overch padch))
1310    
1311           (digits                          ; fixed precision
1312    
1313          (let ((digits (if (> scale 0)          (let ((digits (if (> scale 0)
1314                            (if (< scale (+ digits 2))                            (if (< scale (+ digits 2))
# Line 1312  Line 1343 
1343                            (format:en-out edigits expch)))))                            (format:en-out edigits expch)))))
1344                (begin                (begin
1345                  (format:fn-out modifier #t)                  (format:fn-out modifier #t)
1346                  (format:en-out edigits expch))))                  (format:en-out edigits expch)))))
1347    
1348          (begin                          ; free precision         (else
1349            (format:parse-float          (format:parse-float
1350             (if (string? number) number (number->string number)) #f scale)           (if (string? number) number (number->string number)) #f scale)
1351            (format:fn-strip)          (format:fn-strip)
1352            (if width          (if width
1353                (if (and edigits overch (> format:en-len edigits))              (if (and edigits overch (> format:en-len edigits))
1354                    (format:out-fill width (integer->char overch))                  (format:out-fill width (integer->char overch))
1355                    (let ((numlen (+ format:fn-len 3))) ; .E+                  (let ((numlen (+ format:fn-len 3))) ; .E+
1356                      (if (or (not format:fn-pos?) (eq? modifier 'at))                    (if (or (not format:fn-pos?) (eq? modifier 'at))
1357                          (set! numlen (+ numlen 1)))                        (set! numlen (+ numlen 1)))
1358                      (if (= format:fn-dot 0)                    (if (= format:fn-dot 0)
1359                          (set! numlen (+ numlen 1)))                        (set! numlen (+ numlen 1)))
1360                      (set! numlen                    (set! numlen
1361                            (+ numlen                          (+ numlen
1362                               (if (and edigits (>= edigits format:en-len))                             (if (and edigits (>= edigits format:en-len))
1363                                   edigits                                 edigits
1364                                   format:en-len)))                                 format:en-len)))
1365                      (if (< numlen width)                    (if (< numlen width)
1366                          (format:out-fill (- width numlen)                        (format:out-fill (- width numlen)
1367                                           (integer->char padch)))                                         (integer->char padch)))
1368                      (if (> numlen width) ; adjust precision if possible                    (if (> numlen width) ; adjust precision if possible
1369                          (let ((f (- format:fn-len format:fn-dot))) ; fract len                        (let ((f (- format:fn-len format:fn-dot))) ; fract len
1370                            (if (> (- numlen f) width)                          (if (> (- numlen f) width)
1371                                (if overch ; numstr too big for required width                              (if overch ; numstr too big for required width
1372                                    (format:out-fill width                                  (format:out-fill width
1373                                                     (integer->char overch))                                                   (integer->char overch))
1374                                    (begin                                  (begin
1375                                      (format:fn-out modifier #t)                                    (format:fn-out modifier #t)
1376                                      (format:en-out edigits expch)))                                    (format:en-out edigits expch)))
1377                                (begin                              (begin
1378                                  (format:fn-round (+ (- f numlen) width))                                (format:fn-round (+ (- f numlen) width))
1379                                  (format:fn-out modifier #t)                                (format:fn-out modifier #t)
1380                                  (format:en-out edigits expch))))                                (format:en-out edigits expch))))
1381                          (begin                        (begin
1382                            (format:fn-out modifier #t)                          (format:fn-out modifier #t)
1383                            (format:en-out edigits expch)))))                          (format:en-out edigits expch)))))
1384                (begin              (begin
1385                  (format:fn-out modifier #t)                (format:fn-out modifier #t)
1386                  (format:en-out edigits expch))))))))                (format:en-out edigits expch))))))))
1387                    
1388  ;; format general flonums (~G)  ;; format general flonums (~G)
1389    
# Line 1366  Line 1397 
1397            (edigits (if (> l 2) (list-ref pars 2) #f))            (edigits (if (> l 2) (list-ref pars 2) #f))
1398            (overch (if (> l 4) (list-ref pars 4) #f))            (overch (if (> l 4) (list-ref pars 4) #f))
1399            (padch (if (> l 5) (list-ref pars 5) #f)))            (padch (if (> l 5) (list-ref pars 5) #f)))
1400      (format:parse-float        (cond
1401       (if (string? number) number (number->string number)) #t 0)         ((or (inf? number) (nan? number))
1402      (format:fn-strip)          ;; FIXME: this isn't right.
1403      (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm          (format:out-inf-nan number width digits edigits overch padch))
1404             (ww (if width (- width ee) #f))   ; see Steele's CL book p.395         (else
1405             (n (if (= format:fn-dot 0)   ; number less than (abs 1.0) ?          (format:parse-float
1406                    (- (format:fn-zlead))           (if (string? number) number (number->string number)) #t 0)
1407                    format:fn-dot))          (format:fn-strip)
1408             (d (if digits          (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
1409                    digits                 (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
1410                    (max format:fn-len (min n 7)))) ; q = format:fn-len                 (n (if (= format:fn-dot 0)       ; number less than (abs 1.0) ?
1411             (dd (- d n)))                        (- (format:fn-zlead))
1412        (if (<= 0 dd d)                        format:fn-dot))
1413            (begin                 (d (if digits
1414              (format:out-fixed modifier number (list ww dd #f overch padch))                        digits
1415              (format:out-fill ee #\space)) ;~@T not implemented yet                        (max format:fn-len (min n 7)))) ; q = format:fn-len
1416            (format:out-expon modifier number pars))))))                 (dd (- d n)))
1417              (if (<= 0 dd d)
1418                  (begin
1419                    (format:out-fixed modifier number (list ww dd #f overch padch))
1420                    (format:out-fill ee #\space)) ;~@T not implemented yet
1421                  (format:out-expon modifier number pars))))))))
1422    
1423  ;; format dollar flonums (~$)  ;; format dollar flonums (~$)
1424    

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26