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) |
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 |
|
|
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)) |
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 |
|
|
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 |
|
|