diff options
Diffstat (limited to 'format.scm')
| -rw-r--r-- | format.scm | 2968 |
1 files changed, 1457 insertions, 1511 deletions
@@ -1,5 +1,6 @@ ;;; "format.scm" Common LISP text output formatter for SLIB ; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) +; 2004 Aubrey Jaffer: made reentrant; call slib:error for errors. ; ; This code is in the public domain. @@ -10,11 +11,11 @@ ; ; Version 3.0 -(provide 'format) (require 'string-case) (require 'string-port) (require 'multiarg/and-) (require 'rev4-optional-procedures) +(require-if 'compiling 'pretty-print) ;;; Configuration ------------------------------------------------------------ @@ -53,746 +54,1441 @@ "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space")) +(define format:fn-max 200) ; max. number of number digits +(define format:en-max 10) ; max. number of exponent digits + ;;; End of configuration ---------------------------------------------------- -(define format:version "3.0") -(define format:port #f) ; curr. format output port -(define format:output-col 0) ; curr. format output tty column -(define format:flush-output #f) ; flush output at end of formatting -(define format:case-conversion #f) -(define format:error-continuation #f) -(define format:args #f) -(define format:pos 0) ; curr. format string parsing position -(define format:arg-pos 0) ; curr. format argument position - ; this is global for error presentation - -; format string and char output routines on format:port - -(define (format:out-str str) - (if format:case-conversion - (display (format:case-conversion str) format:port) - (display str format:port)) - (set! format:output-col - (+ format:output-col (string-length str)))) - -(define (format:out-char ch) - (if format:case-conversion - (display (format:case-conversion (string ch)) format:port) +(define format:version "3.1") + +(define format:space-ch (char->integer #\space)) +(define format:zero-ch (char->integer #\0)) + +(define format:parameter-characters + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) + +;; cardinals & ordinals (from dorai@cs.rice.edu) + +(define format:cardinal-thousand-block-list + '("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion" " undecillion" " duodecillion" " tredecillion" + " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" + " octodecillion" " novemdecillion" " vigintillion")) + +(define format:cardinal-ones-list + '(#f "one" "two" "three" "four" "five" + "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" + "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" + "nineteen")) + +(define format:cardinal-tens-list + '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" + "ninety")) + +(define format:ordinal-ones-list + '(#f "first" "second" "third" "fourth" "fifth" + "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" + "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" + "eighteenth" "nineteenth")) + +(define format:ordinal-tens-list + '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" + "seventieth" "eightieth" "ninetieth")) + +;; roman numerals (from dorai@cs.rice.edu). + +(define format:roman-alist + '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) + (10 #\X) (5 #\V) (1 #\I))) + +(define format:roman-boundary-values + '(100 100 10 10 1 1 #f)) + +;@ +(define (format . args) + (define format:port #f) ; curr. format output port + (define format:output-col 0) ; curr. format output tty column + (define format:flush-output #f) ; flush output at end of formatting + (define format:case-conversion #f) + (define format:pos 0) ; curr. format string parsing position + + ;; format string and char output routines on format:port + + (define (format:out-str str) + (if format:case-conversion + (display (format:case-conversion str) format:port) + (display str format:port)) + (set! format:output-col + (+ format:output-col (string-length str)))) + + (define (format:out-char ch) + (if format:case-conversion + (display (format:case-conversion (string ch)) format:port) + (write-char ch format:port)) + (set! format:output-col + (if (char=? ch #\newline) + 0 + (+ format:output-col 1)))) + + ;;(define (format:out-substr str i n) ; this allocates a new string + ;; (display (substring str i n) format:port) + ;; (set! format:output-col (+ format:output-col n))) + + (define (format:out-substr str i n) + (do ((k i (+ k 1))) + ((= k n)) + (write-char (string-ref str k) format:port)) + (set! format:output-col (+ format:output-col n))) + + ;;(define (format:out-fill n ch) ; this allocates a new string + ;; (format:out-str (make-string n ch))) + + (define (format:out-fill n ch) + (do ((i 0 (+ i 1))) + ((= i n)) (write-char ch format:port)) - (set! format:output-col - (if (char=? ch #\newline) - 0 - (+ format:output-col 1)))) - -;(define (format:out-substr str i n) ; this allocates a new string -; (display (substring str i n) format:port) -; (set! format:output-col (+ format:output-col n))) - -(define (format:out-substr str i n) - (do ((k i (+ k 1))) - ((= k n)) - (write-char (string-ref str k) format:port)) - (set! format:output-col (+ format:output-col n))) - -;(define (format:out-fill n ch) ; this allocates a new string -; (format:out-str (make-string n ch))) - -(define (format:out-fill n ch) - (do ((i 0 (+ i 1))) - ((= i n)) - (write-char ch format:port)) - (set! format:output-col (+ format:output-col n))) - -; format's user error handler - -(define (format:error . args) ; never returns! - (let ((error-continuation format:error-continuation) - (format-args format:args) - (port (current-error-port))) - (set! format:error format:intern-error) - (if (and (>= (length format:args) 2) - (string? (cadr format:args))) - (let ((format-string (cadr format-args))) - (if (not (zero? format:arg-pos)) - (set! format:arg-pos (- format:arg-pos 1))) - (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ - ~{~a ~}===>~{~a ~})~% " - (car format:args) - (substring format-string 0 format:pos) - (substring format-string format:pos - (string-length format-string)) - (format:list-head (cddr format:args) format:arg-pos) - (list-tail (cddr format:args) format:arg-pos))) - (format port - "~%FORMAT: error with call: (format~{ ~a~})~% " - format:args)) - (apply format port args) - (newline port) - (set! format:error format:error-save) - (set! format:error-continuation error-continuation) - (format:abort) - (format:intern-error "format:abort does not jump to toplevel!"))) - -(define format:error-save format:error) - -(define (format:intern-error . args) ;if something goes wrong in format:error - (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline) - (display " format args: ") (write format:args) (newline) - (display " error args: ") (write args) (newline) - (set! format:error format:error-save) - (format:abort)) - -(define (format:format . args) ; the formatter entry - (set! format:args args) - (set! format:arg-pos 0) - (set! format:pos 0) - (if (< (length args) 1) - (format:error "not enough arguments")) + (set! format:output-col (+ format:output-col n))) + + (define (format:out-obj-padded pad-left obj slashify pars format:read-proof) + (if (null? pars) + (format:out-str (format:obj->str obj slashify format:read-proof)) + (let ((l (length pars))) + (let ((mincol (format:par pars l 0 0 "mincol")) + (colinc (format:par pars l 1 1 "colinc")) + (minpad (format:par pars l 2 0 "minpad")) + (padchar (integer->char + (format:par pars l 3 format:space-ch #f))) + (objstr (format:obj->str obj slashify format:read-proof))) + (if (not pad-left) + (format:out-str objstr)) + (do ((objstr-len (string-length objstr)) + (i minpad (+ i colinc))) + ((>= (+ objstr-len i) mincol) + (format:out-fill i padchar))) + (if pad-left + (format:out-str objstr)))))) + + (define (format:out-num-padded modifier number pars radix) + (if (not (integer? number)) + (slib:error 'format "argument not an integer" number)) + (let ((numstr (number->string number radix))) + (if (and format:radix-pref (not (= radix 10))) + (set! numstr (substring numstr 2 (string-length numstr)))) + (if (and (null? pars) (not modifier)) + (format:out-str numstr) + (let ((l (length pars)) + (numstr-len (string-length numstr))) + (let ((mincol (format:par pars l 0 #f "mincol")) + (padchar (integer->char + (format:par pars l 1 format:space-ch #f))) + (commachar (integer->char + (format:par pars l 2 (char->integer #\,) #f))) + (commawidth (format:par pars l 3 3 "commawidth"))) + (if mincol + (let ((numlen numstr-len)) ; calc. the output len of number + (if (and (memq modifier '(at colon-at)) (> number 0)) + (set! numlen (+ numlen 1))) + (if (memq modifier '(colon colon-at)) + (set! numlen (+ (quotient (- numstr-len + (if (< number 0) 2 1)) + commawidth) + numlen))) + (if (> mincol numlen) + (format:out-fill (- mincol numlen) padchar)))) + (if (and (memq modifier '(at colon-at)) + (> number 0)) + (format:out-char #\+)) + (if (memq modifier '(colon colon-at)) ; insert comma character + (let ((start (remainder numstr-len commawidth)) + (ns (if (< number 0) 1 0))) + (format:out-substr numstr 0 start) + (do ((i start (+ i commawidth))) + ((>= i numstr-len)) + (if (> i ns) + (format:out-char commachar)) + (format:out-substr numstr i (+ i commawidth)))) + (format:out-str numstr))))))) + + (define (format:tabulate modifier pars) + (let ((l (length pars))) + (let ((colnum (format:par pars l 0 1 "colnum")) + (colinc (format:par pars l 1 1 "colinc")) + (padch (integer->char (format:par pars l 2 format:space-ch #f)))) + (case modifier + ((colon colon-at) + (slib:error 'format "unsupported modifier for ~~t" modifier)) + ((at) ; relative tabulation + (format:out-fill + (if (= colinc 0) + colnum ; colnum = colrel + (do ((c 0 (+ c colinc)) + (col (+ format:output-col colnum))) + ((>= c col) + (- c format:output-col)))) + padch)) + (else ; absolute tabulation + (format:out-fill + (cond + ((< format:output-col colnum) + (- colnum format:output-col)) + ((= colinc 0) + 0) + (else + (do ((c colnum (+ c colinc))) + ((>= c format:output-col) + (- c format:output-col))))) + padch)))))) + + + (define format:num->old-roman + (lambda (n) + (if (and (integer? n) (>= n 1)) + (let loop ((n n) + (romans format:roman-alist) + (s '())) + (if (null? romans) (list->string (reverse s)) + (let ((roman-val (caar romans)) + (roman-dgt (cadar romans))) + (do ((q (quotient n roman-val) (- q 1)) + (s s (cons roman-dgt s))) + ((= q 0) + (loop (remainder n roman-val) + (cdr romans) s)))))) + (slib:error 'format "only positive integers can be romanized")))) + + (define format:num->roman + (lambda (n) + (if (and (integer? n) (> n 0)) + (let loop ((n n) + (romans format:roman-alist) + (boundaries format:roman-boundary-values) + (s '())) + (if (null? romans) + (list->string (reverse s)) + (let ((roman-val (caar romans)) + (roman-dgt (cadar romans)) + (bdry (car boundaries))) + (let loop2 ((q (quotient n roman-val)) + (r (remainder n roman-val)) + (s s)) + (if (= q 0) + (if (and bdry (>= r (- roman-val bdry))) + (loop (remainder r bdry) (cdr romans) + (cdr boundaries) + (cons roman-dgt + (append + (cdr (assv bdry romans)) + s))) + (loop r (cdr romans) (cdr boundaries) s)) + (loop2 (- q 1) r (cons roman-dgt s))))))) + (slib:error 'format "only positive integers can be romanized")))) + + (define format:num->cardinal999 + (lambda (n) + ;;this procedure is inspired by the Bruno Haible's CLisp + ;;function format-small-cardinal, which converts numbers + ;;in the range 1 to 999, and is used for converting each + ;;thousand-block in a larger number + (let* ((hundreds (quotient n 100)) + (tens+ones (remainder n 100)) + (tens (quotient tens+ones 10)) + (ones (remainder tens+ones 10))) + (append + (if (> hundreds 0) + (append + (string->list + (list-ref format:cardinal-ones-list hundreds)) + (string->list" hundred") + (if (> tens+ones 0) '(#\space) '())) + '()) + (if (< tens+ones 20) + (if (> tens+ones 0) + (string->list + (list-ref format:cardinal-ones-list tens+ones)) + '()) + (append + (string->list + (list-ref format:cardinal-tens-list tens)) + (if (> ones 0) + (cons #\- + (string->list + (list-ref format:cardinal-ones-list ones))) + '()))))))) + + (define format:num->cardinal + (lambda (n) + (cond ((not (integer? n)) + (slib:error 'format + "only integers can be converted to English cardinals")) + ((= n 0) "zero") + ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) + (else + (let ((power3-word-limit + (length format:cardinal-thousand-block-list))) + (let loop ((n n) + (power3 0) + (s '())) + (if (= n 0) + (list->string s) + (let ((n-before-block (quotient n 1000)) + (n-after-block (remainder n 1000))) + (loop n-before-block + (+ power3 1) + (if (> n-after-block 0) + (append + (if (> n-before-block 0) + (string->list ", ") '()) + (format:num->cardinal999 n-after-block) + (if (< power3 power3-word-limit) + (string->list + (list-ref + format:cardinal-thousand-block-list + power3)) + (append + (string->list " times ten to the ") + (string->list + (format:num->ordinal + (* power3 3))) + (string->list " power"))) + s) + s)))))))))) + + (define format:num->ordinal + (lambda (n) + (cond ((not (integer? n)) + (slib:error 'format + "only integers can be converted to English ordinals")) + ((= n 0) "zeroth") + ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) + (else + (let ((hundreds (quotient n 100)) + (tens+ones (remainder n 100))) + (string-append + (if (> hundreds 0) + (string-append + (format:num->cardinal (* hundreds 100)) + (if (= tens+ones 0) "th" " ")) + "") + (if (= tens+ones 0) "" + (if (< tens+ones 20) + (list-ref format:ordinal-ones-list tens+ones) + (let ((tens (quotient tens+ones 10)) + (ones (remainder tens+ones 10))) + (if (= ones 0) + (list-ref format:ordinal-tens-list tens) + (string-append + (list-ref format:cardinal-tens-list tens) + "-" + (list-ref format:ordinal-ones-list ones)))) + )))))))) + + ;; format fixed flonums (~F) + + (define (format:out-fixed modifier number pars) + (if (not (or (number? number) (string? number))) + (slib:error 'format "argument is not a number or a number string" + number)) + + (let ((l (length pars))) + (let ((width (format:par pars l 0 #f "width")) + (digits (format:par pars l 1 #f "digits")) + (scale (format:par pars l 2 0 #f)) + (overch (format:par pars l 3 #f #f)) + (padch (format:par pars l 4 format:space-ch #f))) + + (if digits + + (begin ; fixed precision + (format:parse-float + (if (string? number) number (number->string number)) #t scale) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (if width + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (and (= format:fn-dot 0) (> width (+ digits 1))) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (format:out-fill (- width numlen) (integer->char padch))) + (if (and overch (> numlen width)) + (format:out-fill width (integer->char overch)) + (format:fn-out modifier (> width (+ digits 1))))) + (format:fn-out modifier #t))) + + (begin ; free precision + (format:parse-float + (if (string? number) number (number->string number)) #t scale) + (format:fn-strip) + (if width + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (= format:fn-dot 0) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (format:out-fill (- width numlen) (integer->char padch))) + (if (> numlen width) ; adjust precision if possible + (let ((dot-index (- numlen + (- format:fn-len format:fn-dot)))) + (if (> dot-index width) + (if overch ; numstr too big for required width + (format:out-fill width (integer->char overch)) + (format:fn-out modifier #t)) + (begin + (format:fn-round (- width dot-index)) + (format:fn-out modifier #t)))) + (format:fn-out modifier #t))) + (format:fn-out modifier #t))))))) + + ;; format exponential flonums (~E) + + (define (format:out-expon modifier number pars) + (if (not (or (number? number) (string? number))) + (slib:error 'format "argument is not a number" number)) + + (let ((l (length pars))) + (let ((width (format:par pars l 0 #f "width")) + (digits (format:par pars l 1 #f "digits")) + (edigits (format:par pars l 2 #f "exponent digits")) + (scale (format:par pars l 3 1 #f)) + (overch (format:par pars l 4 #f #f)) + (padch (format:par pars l 5 format:space-ch #f)) + (expch (format:par pars l 6 #f #f))) + + (if digits ; fixed precision + + (let ((digits (if (> scale 0) + (if (< scale (+ digits 2)) + (+ (- digits scale) 1) + 0) + digits))) + (format:parse-float + (if (string? number) number (number->string number)) #f scale) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (if width + (if (and edigits overch (> format:en-len edigits)) + (format:out-fill width (integer->char overch)) + (let ((numlen (+ format:fn-len 3))) ; .E+ + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (and (= format:fn-dot 0) (> width (+ digits 1))) + (set! numlen (+ numlen 1))) + (set! numlen + (+ numlen + (if (and edigits (>= edigits format:en-len)) + edigits + format:en-len))) + (if (< numlen width) + (format:out-fill (- width numlen) + (integer->char padch))) + (if (and overch (> numlen width)) + (format:out-fill width (integer->char overch)) + (begin + (format:fn-out modifier (> width (- numlen 1))) + (format:en-out edigits expch))))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch)))) + + (begin ; free precision + (format:parse-float + (if (string? number) number (number->string number)) #f scale) + (format:fn-strip) + (if width + (if (and edigits overch (> format:en-len edigits)) + (format:out-fill width (integer->char overch)) + (let ((numlen (+ format:fn-len 3))) ; .E+ + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (= format:fn-dot 0) + (set! numlen (+ numlen 1))) + (set! numlen + (+ numlen + (if (and edigits (>= edigits format:en-len)) + edigits + format:en-len))) + (if (< numlen width) + (format:out-fill (- width numlen) + (integer->char padch))) + (if (> numlen width) ; adjust precision if possible + (let ((f (- format:fn-len format:fn-dot))) ; fract len + (if (> (- numlen f) width) + (if overch ; numstr too big for required width + (format:out-fill width + (integer->char overch)) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))) + (begin + (format:fn-round (+ (- f numlen) width)) + (format:fn-out modifier #t) + (format:en-out edigits expch)))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch)))))))) + + ;; format general flonums (~G) + + (define (format:out-general modifier number pars) + (if (not (or (number? number) (string? number))) + (slib:error 'format "argument is not a number or a number string" + number)) + + (let ((l (length pars))) + (let ((width (if (> l 0) (list-ref pars 0) #f)) + (digits (if (> l 1) (list-ref pars 1) #f)) + (edigits (if (> l 2) (list-ref pars 2) #f)) + (overch (if (> l 4) (list-ref pars 4) #f)) + (padch (if (> l 5) (list-ref pars 5) #f))) + (format:parse-float + (if (string? number) number (number->string number)) #t 0) + (format:fn-strip) + (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm + (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 + (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? + (- (format:fn-zlead)) + format:fn-dot)) + (d (if digits + digits + (max format:fn-len (min n 7)))) ; q = format:fn-len + (dd (- d n))) + (if (<= 0 dd d) + (begin + (format:out-fixed modifier number (list ww dd #f overch padch)) + (format:out-fill ee #\space)) ;~@T not implemented yet + (format:out-expon modifier number pars)))))) + + ;; format dollar flonums (~$) + + (define (format:out-dollar modifier number pars) + (if (not (or (number? number) (string? number))) + (slib:error 'format "argument is not a number or a number string" + number)) + + (let ((l (length pars))) + (let ((digits (format:par pars l 0 2 "digits")) + (mindig (format:par pars l 1 1 "mindig")) + (width (format:par pars l 2 0 "width")) + (padch (format:par pars l 3 format:space-ch #f))) + + (format:parse-float + (if (string? number) number (number->string number)) #t 0) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) + (set! numlen (+ numlen 1))) + (if (and mindig (> mindig format:fn-dot)) + (set! numlen (+ numlen (- mindig format:fn-dot)))) + (if (and (= format:fn-dot 0) (not mindig)) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (case modifier + ((colon) + (if (not format:fn-pos?) + (format:out-char #\-)) + (format:out-fill (- width numlen) (integer->char padch))) + ((at) + (format:out-fill (- width numlen) (integer->char padch)) + (format:out-char (if format:fn-pos? #\+ #\-))) + ((colon-at) + (format:out-char (if format:fn-pos? #\+ #\-)) + (format:out-fill (- width numlen) (integer->char padch))) + (else + (format:out-fill (- width numlen) (integer->char padch)) + (if (not format:fn-pos?) + (format:out-char #\-)))) + (if format:fn-pos? + (if (memq modifier '(at colon-at)) (format:out-char #\+)) + (format:out-char #\-)))) + (if (and mindig (> mindig format:fn-dot)) + (format:out-fill (- mindig format:fn-dot) #\0)) + (if (and (= format:fn-dot 0) (not mindig)) + (format:out-char #\0)) + (format:out-substr format:fn-str 0 format:fn-dot) + (format:out-char #\.) + (format:out-substr format:fn-str format:fn-dot format:fn-len)))) + + ; the flonum buffers + + (define format:fn-str (make-string format:fn-max)) ; number buffer + (define format:fn-len 0) ; digit length of number + (define format:fn-dot #f) ; dot position of number + (define format:fn-pos? #t) ; number positive? + (define format:en-str (make-string format:en-max)) ; exponent buffer + (define format:en-len 0) ; digit length of exponent + (define format:en-pos? #t) ; exponent positive? + + (define (format:parse-float num-str fixed? scale) + (set! format:fn-pos? #t) + (set! format:fn-len 0) + (set! format:fn-dot #f) + (set! format:en-pos? #t) + (set! format:en-len 0) + (do ((i 0 (+ i 1)) + (left-zeros 0) + (mantissa? #t) + (all-zeros? #t) + (num-len (string-length num-str)) + (c #f)) ; current exam. character in num-str + ((= i num-len) + (if (not format:fn-dot) + (set! format:fn-dot format:fn-len)) + + (if all-zeros? + (begin + (set! left-zeros 0) + (set! format:fn-dot 0) + (set! format:fn-len 1))) + + ;; now format the parsed values according to format's need + + (if fixed? + + (begin ; fixed format m.nnn or .nnn + (if (and (> left-zeros 0) (> format:fn-dot 0)) + (if (> format:fn-dot left-zeros) + (begin ; norm 0{0}nn.mm to nn.mm + (format:fn-shiftleft left-zeros) + (set! left-zeros 0) + (set! format:fn-dot (- format:fn-dot left-zeros))) + (begin ; normalize 0{0}.nnn to .nnn + (format:fn-shiftleft format:fn-dot) + (set! left-zeros (- left-zeros format:fn-dot)) + (set! format:fn-dot 0)))) + (if (or (not (= scale 0)) (> format:en-len 0)) + (let ((shift (+ scale (format:en-int)))) + (cond + (all-zeros? #t) + ((> (+ format:fn-dot shift) format:fn-len) + (format:fn-zfill + #f (- shift (- format:fn-len format:fn-dot))) + (set! format:fn-dot format:fn-len)) + ((< (+ format:fn-dot shift) 0) + (format:fn-zfill #t (- (- shift) format:fn-dot)) + (set! format:fn-dot 0)) + (else + (if (> left-zeros 0) + (if (<= left-zeros shift) ; shift always > 0 here + (format:fn-shiftleft shift) ; shift out 0s + (begin + (format:fn-shiftleft left-zeros) + (set! format:fn-dot (- shift left-zeros)))) + (set! format:fn-dot (+ format:fn-dot shift)))))))) + + (let ((negexp ; expon format m.nnnEee + (if (> left-zeros 0) + (- left-zeros format:fn-dot -1) + (if (= format:fn-dot 0) 1 0)))) + (if (> left-zeros 0) + (begin ; normalize 0{0}.nnn to n.nn + (format:fn-shiftleft left-zeros) + (set! format:fn-dot 1)) + (if (= format:fn-dot 0) + (set! format:fn-dot 1))) + (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) + negexp)) + (cond + (all-zeros? + (format:en-set 0) + (set! format:fn-dot 1)) + ((< scale 0) ; leading zero + (format:fn-zfill #t (- scale)) + (set! format:fn-dot 0)) + ((> scale format:fn-dot) + (format:fn-zfill #f (- scale format:fn-dot)) + (set! format:fn-dot scale)) + (else + (set! format:fn-dot scale))))) + #t) + + ;; do body + (set! c (string-ref num-str i)) ; parse the output of number->string + (cond ; which can be any valid number + ((char-numeric? c) ; representation of R4RS except + (if mantissa? ; complex numbers + (begin + (if (char=? c #\0) + (if all-zeros? + (set! left-zeros (+ left-zeros 1))) + (begin + (set! all-zeros? #f))) + (string-set! format:fn-str format:fn-len c) + (set! format:fn-len (+ format:fn-len 1))) + (begin + (string-set! format:en-str format:en-len c) + (set! format:en-len (+ format:en-len 1))))) + ((or (char=? c #\-) (char=? c #\+)) + (if mantissa? + (set! format:fn-pos? (char=? c #\+)) + (set! format:en-pos? (char=? c #\+)))) + ((char=? c #\.) + (set! format:fn-dot format:fn-len)) + ((char=? c #\e) + (set! mantissa? #f)) + ((char=? c #\E) + (set! mantissa? #f)) + ((char-whitespace? c) #t) + ((char=? c #\d) #t) ; decimal radix prefix + ((char=? c #\#) #t) + (else + (slib:error 'format "illegal character in number->string" c))))) + + (define (format:en-int) ; convert exponent string to integer + (if (= format:en-len 0) + 0 + (do ((i 0 (+ i 1)) + (n 0)) + ((= i format:en-len) + (if format:en-pos? + n + (- n))) + (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) + format:zero-ch)))))) + + (define (format:en-set en) ; set exponent string number + (set! format:en-len 0) + (set! format:en-pos? (>= en 0)) + (let ((en-str (number->string en))) + (do ((i 0 (+ i 1)) + (en-len (string-length en-str)) + (c #f)) + ((= i en-len)) + (set! c (string-ref en-str i)) + (if (char-numeric? c) + (begin + (string-set! format:en-str format:en-len c) + (set! format:en-len (+ format:en-len 1))))))) + + (define (format:fn-zfill left? n) ; fill current number string with 0s + (if (> (+ n format:fn-len) format:fn-max) ; from the left or right + (slib:error 'format "number is too long to format (enlarge format:fn-max)")) + (set! format:fn-len (+ format:fn-len n)) + (if left? + (do ((i format:fn-len (- i 1))) ; fill n 0s to left + ((< i 0)) + (string-set! format:fn-str i + (if (< i n) + #\0 + (string-ref format:fn-str (- i n))))) + (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right + ((= i format:fn-len)) + (string-set! format:fn-str i #\0)))) + + (define (format:fn-shiftleft n) ; shift left current number n positions + (if (> n format:fn-len) + (slib:error 'format "internal error in format:fn-shiftleft" + (list n format:fn-len))) + (do ((i n (+ i 1))) + ((= i format:fn-len) + (set! format:fn-len (- format:fn-len n))) + (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))) + + (define (format:fn-round digits) ; round format:fn-str + (set! digits (+ digits format:fn-dot)) + (do ((i digits (- i 1)) ; "099",2 -> "10" + (c 5)) ; "023",2 -> "02" + ((or (= c 0) (< i 0)) ; "999",2 -> "100" + (if (= c 1) ; "005",2 -> "01" + (begin ; carry overflow + (set! format:fn-len digits) + (format:fn-zfill #t 1) ; add a 1 before fn-str + (string-set! format:fn-str 0 #\1) + (set! format:fn-dot (+ format:fn-dot 1))) + (set! format:fn-len digits))) + (set! c (+ (- (char->integer (string-ref format:fn-str i)) + format:zero-ch) c)) + (string-set! format:fn-str i (integer->char + (if (< c 10) + (+ c format:zero-ch) + (+ (- c 10) format:zero-ch)))) + (set! c (if (< c 10) 0 1)))) + + (define (format:fn-out modifier add-leading-zero?) + (if format:fn-pos? + (if (eq? modifier 'at) + (format:out-char #\+)) + (format:out-char #\-)) + (if (= format:fn-dot 0) + (if add-leading-zero? + (format:out-char #\0)) + (format:out-substr format:fn-str 0 format:fn-dot)) + (format:out-char #\.) + (format:out-substr format:fn-str format:fn-dot format:fn-len)) + + (define (format:en-out edigits expch) + (format:out-char (if expch (integer->char expch) format:expch)) + (format:out-char (if format:en-pos? #\+ #\-)) + (if edigits + (if (< format:en-len edigits) + (format:out-fill (- edigits format:en-len) #\0))) + (format:out-substr format:en-str 0 format:en-len)) + + (define (format:fn-strip) ; strip trailing zeros but one + (string-set! format:fn-str format:fn-len #\0) + (do ((i format:fn-len (- i 1))) + ((or (not (char=? (string-ref format:fn-str i) #\0)) + (<= i format:fn-dot)) + (set! format:fn-len (+ i 1))))) + + (define (format:fn-zlead) ; count leading zeros + (do ((i 0 (+ i 1))) + ((or (= i format:fn-len) + (not (char=? (string-ref format:fn-str i) #\0))) + (if (= i format:fn-len) ; found a real zero + 0 + i)))) + + (define (format:format-work format-string arglist) ; does the formatting work + (letrec + ((format-string-len (string-length format-string)) + (arg-pos 0) ; argument position in arglist + (arg-len (length arglist)) ; number of arguments + (modifier #f) ; 'colon | 'at | 'colon-at | #f + (params '()) ; directive parameter list + (param-value-found #f) ; a directive parameter value found + (conditional-nest 0) ; conditional nesting level + (clause-pos 0) ; last cond. clause beginning char pos + (clause-default #f) ; conditional default clause string + (clauses '()) ; conditional clause string list + (conditional-type #f) ; reflects the contional modifiers + (conditional-arg #f) ; argument to apply the conditional + (iteration-nest 0) ; iteration nesting level + (iteration-pos 0) ; iteration string beginning char pos + (iteration-type #f) ; reflects the iteration modifiers + (max-iterations #f) ; maximum number of iterations + (recursive-pos-save format:pos) + + (next-char ; gets the next char from format-string + (lambda () + (let ((ch (peek-next-char))) + (set! format:pos (+ 1 format:pos)) + ch))) + + (peek-next-char + (lambda () + (if (>= format:pos format-string-len) + (slib:error 'format "illegal format string") + (string-ref format-string format:pos)))) + + (one-positive-integer? + (lambda (params) + (cond + ((null? params) #f) + ((and (integer? (car params)) + (>= (car params) 0) + (= (length params) 1)) #t) + (else (slib:error 'format "one positive integer parameter expected"))))) + + (next-arg + (lambda () + (if (>= arg-pos arg-len) + (begin + (slib:error 'format "missing argument(s)"))) + (add-arg-pos 1) + (list-ref arglist (- arg-pos 1)))) + + (prev-arg + (lambda () + (add-arg-pos -1) + (if (negative? arg-pos) + (slib:error 'format "missing backward argument(s)")) + (list-ref arglist arg-pos))) + + (rest-args + (lambda () + (let loop ((l arglist) (k arg-pos)) ; list-tail definition + (if (= k 0) l (loop (cdr l) (- k 1)))))) + + (add-arg-pos + (lambda (n) + (set! arg-pos (+ n arg-pos)))) + + (anychar-dispatch ; dispatches the format-string + (lambda () + (if (>= format:pos format-string-len) + arg-pos ; used for ~? continuance + (let ((char (next-char))) + (cond + ((char=? char #\~) + (set! modifier #f) + (set! params '()) + (set! param-value-found #f) + (tilde-dispatch)) + (else + (if (and (zero? conditional-nest) + (zero? iteration-nest)) + (format:out-char char)) + (anychar-dispatch))))))) + + (tilde-dispatch + (lambda () + (cond + ((>= format:pos format-string-len) + (format:out-str "~") ; tilde at end of string is just output + arg-pos) ; used for ~? continuance + ((and (or (zero? conditional-nest) + (memv (peek-next-char) ; find conditional directives + (append '(#\[ #\] #\; #\: #\@ #\^) + format:parameter-characters))) + (or (zero? iteration-nest) + (memv (peek-next-char) ; find iteration directives + (append '(#\{ #\} #\: #\@ #\^) + format:parameter-characters)))) + (case (char-upcase (next-char)) + + ;; format directives + + ((#\A) ; Any -- for humans + (format:out-obj-padded (memq modifier '(at colon-at)) + (next-arg) #f params + (memq modifier '(colon colon-at))) + (anychar-dispatch)) + ((#\S) ; Slashified -- for parsers + (format:out-obj-padded (memq modifier '(at colon-at)) + (next-arg) #t params + (memq modifier '(colon colon-at))) + (anychar-dispatch)) + ((#\D) ; Decimal + (format:out-num-padded modifier (next-arg) params 10) + (anychar-dispatch)) + ((#\X) ; Hexadecimal + (format:out-num-padded modifier (next-arg) params 16) + (anychar-dispatch)) + ((#\O) ; Octal + (format:out-num-padded modifier (next-arg) params 8) + (anychar-dispatch)) + ((#\B) ; Binary + (format:out-num-padded modifier (next-arg) params 2) + (anychar-dispatch)) + ((#\R) + (if (null? params) + (format:out-obj-padded ; Roman, cardinal, ordinal numerals + #f + ((case modifier + ((at) format:num->roman) + ((colon-at) format:num->old-roman) + ((colon) format:num->ordinal) + (else format:num->cardinal)) + (next-arg)) + #f params #f) ;was format:read-proof + (format:out-num-padded ; any Radix + modifier (next-arg) (cdr params) (car params))) + (anychar-dispatch)) + ((#\F) ; Fixed-format floating-point + (if format:floats + (format:out-fixed modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\E) ; Exponential floating-point + (if format:floats + (format:out-expon modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\G) ; General floating-point + (if format:floats + (format:out-general modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\$) ; Dollars floating-point + (if format:floats + (format:out-dollar modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\I) ; Complex numbers + (if (not format:complex-numbers) + (slib:error 'format + "complex numbers not supported by this scheme system")) + (let ((z (next-arg))) + (if (not (complex? z)) + (slib:error 'format "argument not a complex number")) + (format:out-fixed modifier (real-part z) params) + (format:out-fixed 'at (imag-part z) params) + (format:out-char #\i)) + (anychar-dispatch)) + ((#\C) ; Character + (let ((ch (if (one-positive-integer? params) + (integer->char (car params)) + (next-arg)))) + (if (not (char? ch)) (slib:error 'format "~~c expects a character" ch)) + (case modifier + ((at) + (format:out-str (format:char->str ch))) + ((colon) + (let ((c (char->integer ch))) + (if (< c 0) + (set! c (+ c 256))) ; compensate complement impl. + (cond + ((< c #x20) ; assumes that control chars are < #x20 + (format:out-char #\^) + (format:out-char + (integer->char (+ c #x40)))) + ((>= c #x7f) + (format:out-str "#\\") + (format:out-str + (if format:radix-pref + (let ((s (number->string c 8))) + (substring s 2 (string-length s))) + (number->string c 8)))) + (else + (format:out-char ch))))) + (else (format:out-char ch)))) + (anychar-dispatch)) + ((#\P) ; Plural + (if (memq modifier '(colon colon-at)) + (prev-arg)) + (let ((arg (next-arg))) + (if (not (number? arg)) + (slib:error 'format "~~p expects a number argument" arg)) + (if (= arg 1) + (if (memq modifier '(at colon-at)) + (format:out-char #\y)) + (if (memq modifier '(at colon-at)) + (format:out-str "ies") + (format:out-char #\s)))) + (anychar-dispatch)) + ((#\~) ; Tilde + (if (one-positive-integer? params) + (format:out-fill (car params) #\~) + (format:out-char #\~)) + (anychar-dispatch)) + ((#\%) ; Newline + (if (one-positive-integer? params) + (format:out-fill (car params) #\newline) + (format:out-char #\newline)) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\&) ; Fresh line + (if (one-positive-integer? params) + (begin + (if (> (car params) 0) + (format:out-fill (- (car params) + (if (> format:output-col 0) 0 1)) + #\newline)) + (set! format:output-col 0)) + (if (> format:output-col 0) + (format:out-char #\newline))) + (anychar-dispatch)) + ((#\_) ; Space character + (if (one-positive-integer? params) + (format:out-fill (car params) #\space) + (format:out-char #\space)) + (anychar-dispatch)) + ((#\/) ; Tabulator character + (if (one-positive-integer? params) + (format:out-fill (car params) slib:tab) + (format:out-char slib:tab)) + (anychar-dispatch)) + ((#\|) ; Page seperator + (if (one-positive-integer? params) + (format:out-fill (car params) slib:form-feed) + (format:out-char slib:form-feed)) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\T) ; Tabulate + (format:tabulate modifier params) + (anychar-dispatch)) + ((#\Y) ; Pretty-print + (require 'pretty-print) + (pretty-print (next-arg) format:port) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\? #\K) ; Indirection (is "~K" in T-Scheme) + (cond + ((memq modifier '(colon colon-at)) + (slib:error 'format "illegal modifier in ~~?" modifier)) + ((eq? modifier 'at) + (let* ((frmt (next-arg)) + (args (rest-args))) + (add-arg-pos (format:format-work frmt args)))) + (else + (let* ((frmt (next-arg)) + (args (next-arg))) + (format:format-work frmt args)))) + (anychar-dispatch)) + ((#\!) ; Flush output + (set! format:flush-output #t) + (anychar-dispatch)) + ((#\newline) ; Continuation lines + (if (eq? modifier 'at) + (format:out-char #\newline)) + (if (< format:pos format-string-len) + (do ((ch (peek-next-char) (peek-next-char))) + ((or (not (char-whitespace? ch)) + (= format:pos (- format-string-len 1)))) + (if (eq? modifier 'colon) + (format:out-char (next-char)) + (next-char)))) + (anychar-dispatch)) + ((#\*) ; Argument jumping + (case modifier + ((colon) ; jump backwards + (if (one-positive-integer? params) + (do ((i 0 (+ i 1))) + ((= i (car params))) + (prev-arg)) + (prev-arg))) + ((at) ; jump absolute + (set! arg-pos (if (one-positive-integer? params) + (car params) 0))) + ((colon-at) + (slib:error 'format "illegal modifier `:@' in ~~* directive")) + (else ; jump forward + (if (one-positive-integer? params) + (do ((i 0 (+ i 1))) + ((= i (car params))) + (next-arg)) + (next-arg)))) + (anychar-dispatch)) + ((#\() ; Case conversion begin + (set! format:case-conversion + (case modifier + ((at) format:string-capitalize-first) + ((colon) string-capitalize) + ((colon-at) string-upcase) + (else string-downcase))) + (anychar-dispatch)) + ((#\)) ; Case conversion end + (if (not format:case-conversion) + (slib:error 'format "missing ~~(")) + (set! format:case-conversion #f) + (anychar-dispatch)) + ((#\[) ; Conditional begin + (set! conditional-nest (+ conditional-nest 1)) + (cond + ((= conditional-nest 1) + (set! clause-pos format:pos) + (set! clause-default #f) + (set! clauses '()) + (set! conditional-type + (case modifier + ((at) 'if-then) + ((colon) 'if-else-then) + ((colon-at) (slib:error 'format "illegal modifier in ~~[")) + (else 'num-case))) + (set! conditional-arg + (if (one-positive-integer? params) + (car params) + (next-arg))))) + (anychar-dispatch)) + ((#\;) ; Conditional separator + (if (zero? conditional-nest) + (slib:error 'format "~~; not in ~~[~~] conditional")) + (if (not (null? params)) + (slib:error 'format "no parameter allowed in ~~;")) + (if (= conditional-nest 1) + (let ((clause-str + (cond + ((eq? modifier 'colon) + (set! clause-default #t) + (substring format-string clause-pos + (- format:pos 3))) + ((memq modifier '(at colon-at)) + (slib:error 'format "illegal modifier in ~~;")) + (else + (substring format-string clause-pos + (- format:pos 2)))))) + (set! clauses (append clauses (list clause-str))) + (set! clause-pos format:pos))) + (anychar-dispatch)) + ((#\]) ; Conditional end + (if (zero? conditional-nest) (slib:error 'format "missing ~~[")) + (set! conditional-nest (- conditional-nest 1)) + (if modifier + (slib:error 'format "no modifier allowed in ~~]")) + (if (not (null? params)) + (slib:error 'format "no parameter allowed in ~~]")) + (cond + ((zero? conditional-nest) + (let ((clause-str (substring format-string clause-pos + (- format:pos 2)))) + (if clause-default + (set! clause-default clause-str) + (set! clauses (append clauses (list clause-str))))) + (case conditional-type + ((if-then) + (if conditional-arg + (format:format-work (car clauses) + (list conditional-arg)))) + ((if-else-then) + (add-arg-pos + (format:format-work (if conditional-arg + (cadr clauses) + (car clauses)) + (rest-args)))) + ((num-case) + (if (or (not (integer? conditional-arg)) + (< conditional-arg 0)) + (slib:error 'format "argument not a positive integer")) + (if (not (and (>= conditional-arg (length clauses)) + (not clause-default))) + (add-arg-pos + (format:format-work + (if (>= conditional-arg (length clauses)) + clause-default + (list-ref clauses conditional-arg)) + (rest-args)))))))) + (anychar-dispatch)) + ((#\{) ; Iteration begin + (set! iteration-nest (+ iteration-nest 1)) + (cond + ((= iteration-nest 1) + (set! iteration-pos format:pos) + (set! iteration-type + (case modifier + ((at) 'rest-args) + ((colon) 'sublists) + ((colon-at) 'rest-sublists) + (else 'list))) + (set! max-iterations (if (one-positive-integer? params) + (car params) #f)))) + (anychar-dispatch)) + ((#\}) ; Iteration end + (if (zero? iteration-nest) (slib:error 'format "missing ~~{")) + (set! iteration-nest (- iteration-nest 1)) + (case modifier + ((colon) + (if (not max-iterations) (set! max-iterations 1))) + ((colon-at at) (slib:error 'format "illegal modifier" modifier)) + (else (if (not max-iterations) + (set! max-iterations format:max-iterations)))) + (if (not (null? params)) + (slib:error 'format "no parameters allowed in ~~}" params)) + (if (zero? iteration-nest) + (let ((iteration-str + (substring format-string iteration-pos + (- format:pos (if modifier 3 2))))) + (if (string=? iteration-str "") + (set! iteration-str (next-arg))) + (case iteration-type + ((list) + (let ((args (next-arg)) + (args-len 0)) + (if (not (list? args)) + (slib:error 'format "expected a list argument" args)) + (set! args-len (length args)) + (do ((arg-pos 0 (+ arg-pos + (format:format-work + iteration-str + (list-tail args arg-pos)))) + (i 0 (+ i 1))) + ((or (>= arg-pos args-len) + (and format:iteration-bounded + (>= i max-iterations))))))) + ((sublists) + (let ((args (next-arg)) + (args-len 0)) + (if (not (list? args)) + (slib:error 'format "expected a list argument" args)) + (set! args-len (length args)) + (do ((arg-pos 0 (+ arg-pos 1))) + ((or (>= arg-pos args-len) + (and format:iteration-bounded + (>= arg-pos max-iterations)))) + (let ((sublist (list-ref args arg-pos))) + (if (not (list? sublist)) + (slib:error 'format + "expected a list of lists argument" args)) + (format:format-work iteration-str sublist))))) + ((rest-args) + (let* ((args (rest-args)) + (args-len (length args)) + (usedup-args + (do ((arg-pos 0 (+ arg-pos + (format:format-work + iteration-str + (list-tail + args arg-pos)))) + (i 0 (+ i 1))) + ((or (>= arg-pos args-len) + (and format:iteration-bounded + (>= i max-iterations))) + arg-pos)))) + (add-arg-pos usedup-args))) + ((rest-sublists) + (let* ((args (rest-args)) + (args-len (length args)) + (usedup-args + (do ((arg-pos 0 (+ arg-pos 1))) + ((or (>= arg-pos args-len) + (and format:iteration-bounded + (>= arg-pos max-iterations))) + arg-pos) + (let ((sublist (list-ref args arg-pos))) + (if (not (list? sublist)) + (slib:error 'format "expected list arguments" args)) + (format:format-work iteration-str sublist))))) + (add-arg-pos usedup-args))) + (else (slib:error 'format "internal error in ~~}"))))) + (anychar-dispatch)) + ((#\^) ; Up and out + (let* ((continue + (cond + ((not (null? params)) + (not + (case (length params) + ((1) (zero? (car params))) + ((2) (= (list-ref params 0) (list-ref params 1))) + ((3) (<= (list-ref params 0) + (list-ref params 1) + (list-ref params 2))) + (else (slib:error 'format "too many parameters"))))) + (format:case-conversion ; if conversion stop conversion + (set! format:case-conversion string-copy) #t) + ((= iteration-nest 1) #t) + ((= conditional-nest 1) #t) + ((>= arg-pos arg-len) + (set! format:pos format-string-len) #f) + (else #t)))) + (if continue + (anychar-dispatch)))) + + ;; format directive modifiers and parameters + + ((#\@) ; `@' modifier + (if (memq modifier '(at colon-at)) + (slib:error 'format "double `@' modifier")) + (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) + (tilde-dispatch)) + ((#\:) ; `:' modifier + (if (memq modifier '(colon colon-at)) + (slib:error 'format "double `:' modifier")) + (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) + (tilde-dispatch)) + ((#\') ; Character parameter + (if modifier (slib:error 'format "misplaced modifier" modifier)) + (set! params (append params (list (char->integer (next-char))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr + (if modifier (slib:error 'format "misplaced modifier" modifier)) + (let ((num-str-beg (- format:pos 1)) + (num-str-end format:pos)) + (do ((ch (peek-next-char) (peek-next-char))) + ((not (char-numeric? ch))) + (next-char) + (set! num-str-end (+ 1 num-str-end))) + (set! params + (append params + (list (string->number + (substring format-string + num-str-beg + num-str-end)))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\V) ; Variable parameter from next argum. + (if modifier (slib:error 'format "misplaced modifier" modifier)) + (set! params (append params (list (next-arg)))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\#) ; Parameter is number of remaining args + (if modifier (slib:error 'format "misplaced modifier" modifier)) + (set! params (append params (list (length (rest-args))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\,) ; Parameter separators + (if modifier (slib:error 'format "misplaced modifier" modifier)) + (if (not param-value-found) + (set! params (append params '(#f)))) ; append empty paramtr + (set! param-value-found #f) + (tilde-dispatch)) + ((#\Q) ; Inquiry messages + (if (eq? modifier 'colon) + (format:out-str format:version) + (let ((nl (string #\newline))) + (format:out-str + (string-append + "SLIB Common LISP format version " format:version nl + " This code is in the public domain." nl + " Please send bug reports to `lutzeb@cs.tu-berlin.de'" + nl)))) + (anychar-dispatch)) + (else ; Unknown tilde directive + (slib:error 'format "unknown control character" + (string-ref format-string (- format:pos 1)))))) + (else (anychar-dispatch)))))) ; in case of conditional + + (set! format:pos 0) + (anychar-dispatch) ; start the formatting + (set! format:pos recursive-pos-save) + arg-pos)) + + (define (format:out fmt args) ; the output handler for a port + ;;(set! format:case-conversion #f) ; modifier case conversion procedure + ;;(set! format:flush-output #f) ; ~! reset + (let ((arg-pos (format:format-work fmt args)) + (arg-len (length args))) + (cond ((< arg-pos arg-len) + (set! format:pos (string-length fmt)) + (slib:error 'format (- arg-len arg-pos) "superfluous arguments")) + ((> arg-pos arg-len) + (slib:error 'format (- arg-pos arg-len) "missing arguments"))))) + + ;;(set! format:pos 0) + (if (< (length args) 1) (slib:error 'format "not enough arguments")) ;; If the first argument is a string, then that's the format string. ;; (Scheme->C) ;; In this case, put the argument list in canonical form. - (let ((args (if (string? (car args)) - (cons #f args) - args))) - ;; Use this canonicalized version when reporting errors. - (set! format:args args) - + (let ((args (if (string? (car args)) (cons #f args) args))) (let ((destination (car args)) (arglist (cdr args))) (cond - ((or (and (boolean? destination) ; port output + ((or (and (boolean? destination) ; port output destination) (output-port? destination) (number? destination)) - (format:out (cond - ((boolean? destination) (current-output-port)) - ((output-port? destination) destination) - ((number? destination) (current-error-port))) - (car arglist) (cdr arglist))) + (let ((port (cond ((boolean? destination) (current-output-port)) + ((output-port? destination) destination) + ((number? destination) (current-error-port))))) + (set! format:port port) ; global port for output routines + (set! format:output-col (format:get-port-column port)) + (format:out (car arglist) (cdr arglist)) + (format:set-port-column! port format:output-col) + (if format:flush-output (force-output format:port)) + #t)) ((and (boolean? destination) ; string output (not destination)) (call-with-output-string - (lambda (port) (format:out port (car arglist) (cdr arglist))))) + (lambda (port) + (set! format:port port) + (format:out (car arglist) (cdr arglist))))) (else - (format:error "illegal destination `~a'" destination)))))) - -(define (format:out port fmt args) ; the output handler for a port - (set! format:port port) ; global port for output routines - (set! format:case-conversion #f) ; modifier case conversion procedure - (set! format:flush-output #f) ; ~! reset - (let ((arg-pos (format:format-work fmt args)) - (arg-len (length args))) - (cond - ((< arg-pos arg-len) - (set! format:arg-pos (+ arg-pos 1)) - (set! format:pos (string-length fmt)) - (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) - ((> arg-pos arg-len) - (set! format:arg-pos (+ arg-len 1)) - (display format:arg-pos) - (format:error "~a missing argument~:p" (- arg-pos arg-len))) - (else - (if format:flush-output (force-output port)) - #t)))) + (slib:error 'format "illegal destination" destination)))))) -(define format:parameter-characters - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) +;; format:obj->str returns a R4RS representation as a string of an +;; arbitrary scheme object. -(define (format:format-work format-string arglist) ; does the formatting work - (letrec - ((format-string-len (string-length format-string)) - (arg-pos 0) ; argument position in arglist - (arg-len (length arglist)) ; number of arguments - (modifier #f) ; 'colon | 'at | 'colon-at | #f - (params '()) ; directive parameter list - (param-value-found #f) ; a directive parameter value found - (conditional-nest 0) ; conditional nesting level - (clause-pos 0) ; last cond. clause beginning char pos - (clause-default #f) ; conditional default clause string - (clauses '()) ; conditional clause string list - (conditional-type #f) ; reflects the contional modifiers - (conditional-arg #f) ; argument to apply the conditional - (iteration-nest 0) ; iteration nesting level - (iteration-pos 0) ; iteration string beginning char pos - (iteration-type #f) ; reflects the iteration modifiers - (max-iterations #f) ; maximum number of iterations - (recursive-pos-save format:pos) - - (next-char ; gets the next char from format-string - (lambda () - (let ((ch (peek-next-char))) - (set! format:pos (+ 1 format:pos)) - ch))) - - (peek-next-char - (lambda () - (if (>= format:pos format-string-len) - (format:error "illegal format string") - (string-ref format-string format:pos)))) - - (one-positive-integer? - (lambda (params) - (cond - ((null? params) #f) - ((and (integer? (car params)) - (>= (car params) 0) - (= (length params) 1)) #t) - (else (format:error "one positive integer parameter expected"))))) - - (next-arg - (lambda () - (if (>= arg-pos arg-len) - (begin - (set! format:arg-pos (+ arg-len 1)) - (format:error "missing argument(s)"))) - (add-arg-pos 1) - (list-ref arglist (- arg-pos 1)))) - - (prev-arg - (lambda () - (add-arg-pos -1) - (if (negative? arg-pos) - (format:error "missing backward argument(s)")) - (list-ref arglist arg-pos))) - - (rest-args - (lambda () - (let loop ((l arglist) (k arg-pos)) ; list-tail definition - (if (= k 0) l (loop (cdr l) (- k 1)))))) - - (add-arg-pos - (lambda (n) - (set! arg-pos (+ n arg-pos)) - (set! format:arg-pos arg-pos))) - - (anychar-dispatch ; dispatches the format-string - (lambda () - (if (>= format:pos format-string-len) - arg-pos ; used for ~? continuance - (let ((char (next-char))) - (cond - ((char=? char #\~) - (set! modifier #f) - (set! params '()) - (set! param-value-found #f) - (tilde-dispatch)) - (else - (if (and (zero? conditional-nest) - (zero? iteration-nest)) - (format:out-char char)) - (anychar-dispatch))))))) - - (tilde-dispatch - (lambda () - (cond - ((>= format:pos format-string-len) - (format:out-str "~") ; tilde at end of string is just output - arg-pos) ; used for ~? continuance - ((and (or (zero? conditional-nest) - (memv (peek-next-char) ; find conditional directives - (append '(#\[ #\] #\; #\: #\@ #\^) - format:parameter-characters))) - (or (zero? iteration-nest) - (memv (peek-next-char) ; find iteration directives - (append '(#\{ #\} #\: #\@ #\^) - format:parameter-characters)))) - (case (char-upcase (next-char)) - - ;; format directives - - ((#\A) ; Any -- for humans - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #f params) - (anychar-dispatch)) - ((#\S) ; Slashified -- for parsers - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #t params) - (anychar-dispatch)) - ((#\D) ; Decimal - (format:out-num-padded modifier (next-arg) params 10) - (anychar-dispatch)) - ((#\X) ; Hexadecimal - (format:out-num-padded modifier (next-arg) params 16) - (anychar-dispatch)) - ((#\O) ; Octal - (format:out-num-padded modifier (next-arg) params 8) - (anychar-dispatch)) - ((#\B) ; Binary - (format:out-num-padded modifier (next-arg) params 2) - (anychar-dispatch)) - ((#\R) - (if (null? params) - (format:out-obj-padded ; Roman, cardinal, ordinal numerals - #f - ((case modifier - ((at) format:num->roman) - ((colon-at) format:num->old-roman) - ((colon) format:num->ordinal) - (else format:num->cardinal)) - (next-arg)) - #f params) - (format:out-num-padded ; any Radix - modifier (next-arg) (cdr params) (car params))) - (anychar-dispatch)) - ((#\F) ; Fixed-format floating-point - (if format:floats - (format:out-fixed modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\E) ; Exponential floating-point - (if format:floats - (format:out-expon modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\G) ; General floating-point - (if format:floats - (format:out-general modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\$) ; Dollars floating-point - (if format:floats - (format:out-dollar modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\I) ; Complex numbers - (if (not format:complex-numbers) - (format:error - "complex numbers not supported by this scheme system")) - (let ((z (next-arg))) - (if (not (complex? z)) - (format:error "argument not a complex number")) - (format:out-fixed modifier (real-part z) params) - (format:out-fixed 'at (imag-part z) params) - (format:out-char #\i)) - (anychar-dispatch)) - ((#\C) ; Character - (let ((ch (if (one-positive-integer? params) - (integer->char (car params)) - (next-arg)))) - (if (not (char? ch)) (format:error "~~c expects a character")) - (case modifier - ((at) - (format:out-str (format:char->str ch))) - ((colon) - (let ((c (char->integer ch))) - (if (< c 0) - (set! c (+ c 256))) ; compensate complement impl. - (cond - ((< c #x20) ; assumes that control chars are < #x20 - (format:out-char #\^) - (format:out-char - (integer->char (+ c #x40)))) - ((>= c #x7f) - (format:out-str "#\\") - (format:out-str - (if format:radix-pref - (let ((s (number->string c 8))) - (substring s 2 (string-length s))) - (number->string c 8)))) - (else - (format:out-char ch))))) - (else (format:out-char ch)))) - (anychar-dispatch)) - ((#\P) ; Plural - (if (memq modifier '(colon colon-at)) - (prev-arg)) - (let ((arg (next-arg))) - (if (not (number? arg)) - (format:error "~~p expects a number argument")) - (if (= arg 1) - (if (memq modifier '(at colon-at)) - (format:out-char #\y)) - (if (memq modifier '(at colon-at)) - (format:out-str "ies") - (format:out-char #\s)))) - (anychar-dispatch)) - ((#\~) ; Tilde - (if (one-positive-integer? params) - (format:out-fill (car params) #\~) - (format:out-char #\~)) - (anychar-dispatch)) - ((#\%) ; Newline - (if (one-positive-integer? params) - (format:out-fill (car params) #\newline) - (format:out-char #\newline)) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\&) ; Fresh line - (if (one-positive-integer? params) - (begin - (if (> (car params) 0) - (format:out-fill (- (car params) - (if (> format:output-col 0) 0 1)) - #\newline)) - (set! format:output-col 0)) - (if (> format:output-col 0) - (format:out-char #\newline))) - (anychar-dispatch)) - ((#\_) ; Space character - (if (one-positive-integer? params) - (format:out-fill (car params) #\space) - (format:out-char #\space)) - (anychar-dispatch)) - ((#\/) ; Tabulator character - (if (one-positive-integer? params) - (format:out-fill (car params) slib:tab) - (format:out-char slib:tab)) - (anychar-dispatch)) - ((#\|) ; Page seperator - (if (one-positive-integer? params) - (format:out-fill (car params) slib:form-feed) - (format:out-char slib:form-feed)) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\T) ; Tabulate - (format:tabulate modifier params) - (anychar-dispatch)) - ((#\Y) ; Pretty-print - (require 'pretty-print) - (pretty-print (next-arg) format:port) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\? #\K) ; Indirection (is "~K" in T-Scheme) - (cond - ((memq modifier '(colon colon-at)) - (format:error "illegal modifier in ~~?")) - ((eq? modifier 'at) - (let* ((frmt (next-arg)) - (args (rest-args))) - (add-arg-pos (format:format-work frmt args)))) - (else - (let* ((frmt (next-arg)) - (args (next-arg))) - (format:format-work frmt args)))) - (anychar-dispatch)) - ((#\!) ; Flush output - (set! format:flush-output #t) - (anychar-dispatch)) - ((#\newline) ; Continuation lines - (if (eq? modifier 'at) - (format:out-char #\newline)) - (if (< format:pos format-string-len) - (do ((ch (peek-next-char) (peek-next-char))) - ((or (not (char-whitespace? ch)) - (= format:pos (- format-string-len 1)))) - (if (eq? modifier 'colon) - (format:out-char (next-char)) - (next-char)))) - (anychar-dispatch)) - ((#\*) ; Argument jumping - (case modifier - ((colon) ; jump backwards - (if (one-positive-integer? params) - (do ((i 0 (+ i 1))) - ((= i (car params))) - (prev-arg)) - (prev-arg))) - ((at) ; jump absolute - (set! arg-pos (if (one-positive-integer? params) - (car params) 0))) - ((colon-at) - (format:error "illegal modifier `:@' in ~~* directive")) - (else ; jump forward - (if (one-positive-integer? params) - (do ((i 0 (+ i 1))) - ((= i (car params))) - (next-arg)) - (next-arg)))) - (anychar-dispatch)) - ((#\() ; Case conversion begin - (set! format:case-conversion - (case modifier - ((at) format:string-capitalize-first) - ((colon) string-capitalize) - ((colon-at) string-upcase) - (else string-downcase))) - (anychar-dispatch)) - ((#\)) ; Case conversion end - (if (not format:case-conversion) - (format:error "missing ~~(")) - (set! format:case-conversion #f) - (anychar-dispatch)) - ((#\[) ; Conditional begin - (set! conditional-nest (+ conditional-nest 1)) - (cond - ((= conditional-nest 1) - (set! clause-pos format:pos) - (set! clause-default #f) - (set! clauses '()) - (set! conditional-type - (case modifier - ((at) 'if-then) - ((colon) 'if-else-then) - ((colon-at) (format:error "illegal modifier in ~~[")) - (else 'num-case))) - (set! conditional-arg - (if (one-positive-integer? params) - (car params) - (next-arg))))) - (anychar-dispatch)) - ((#\;) ; Conditional separator - (if (zero? conditional-nest) - (format:error "~~; not in ~~[~~] conditional")) - (if (not (null? params)) - (format:error "no parameter allowed in ~~;")) - (if (= conditional-nest 1) - (let ((clause-str - (cond - ((eq? modifier 'colon) - (set! clause-default #t) - (substring format-string clause-pos - (- format:pos 3))) - ((memq modifier '(at colon-at)) - (format:error "illegal modifier in ~~;")) - (else - (substring format-string clause-pos - (- format:pos 2)))))) - (set! clauses (append clauses (list clause-str))) - (set! clause-pos format:pos))) - (anychar-dispatch)) - ((#\]) ; Conditional end - (if (zero? conditional-nest) (format:error "missing ~~[")) - (set! conditional-nest (- conditional-nest 1)) - (if modifier - (format:error "no modifier allowed in ~~]")) - (if (not (null? params)) - (format:error "no parameter allowed in ~~]")) - (cond - ((zero? conditional-nest) - (let ((clause-str (substring format-string clause-pos - (- format:pos 2)))) - (if clause-default - (set! clause-default clause-str) - (set! clauses (append clauses (list clause-str))))) - (case conditional-type - ((if-then) - (if conditional-arg - (format:format-work (car clauses) - (list conditional-arg)))) - ((if-else-then) - (add-arg-pos - (format:format-work (if conditional-arg - (cadr clauses) - (car clauses)) - (rest-args)))) - ((num-case) - (if (or (not (integer? conditional-arg)) - (< conditional-arg 0)) - (format:error "argument not a positive integer")) - (if (not (and (>= conditional-arg (length clauses)) - (not clause-default))) - (add-arg-pos - (format:format-work - (if (>= conditional-arg (length clauses)) - clause-default - (list-ref clauses conditional-arg)) - (rest-args)))))))) - (anychar-dispatch)) - ((#\{) ; Iteration begin - (set! iteration-nest (+ iteration-nest 1)) - (cond - ((= iteration-nest 1) - (set! iteration-pos format:pos) - (set! iteration-type - (case modifier - ((at) 'rest-args) - ((colon) 'sublists) - ((colon-at) 'rest-sublists) - (else 'list))) - (set! max-iterations (if (one-positive-integer? params) - (car params) #f)))) - (anychar-dispatch)) - ((#\}) ; Iteration end - (if (zero? iteration-nest) (format:error "missing ~~{")) - (set! iteration-nest (- iteration-nest 1)) - (case modifier - ((colon) - (if (not max-iterations) (set! max-iterations 1))) - ((colon-at at) (format:error "illegal modifier")) - (else (if (not max-iterations) - (set! max-iterations format:max-iterations)))) - (if (not (null? params)) - (format:error "no parameters allowed in ~~}")) - (if (zero? iteration-nest) - (let ((iteration-str - (substring format-string iteration-pos - (- format:pos (if modifier 3 2))))) - (if (string=? iteration-str "") - (set! iteration-str (next-arg))) - (case iteration-type - ((list) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos - (format:format-work - iteration-str - (list-tail args arg-pos)))) - (i 0 (+ i 1))) - ((or (>= arg-pos args-len) - (and format:iteration-bounded - (>= i max-iterations))))))) - ((sublists) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (and format:iteration-bounded - (>= arg-pos max-iterations)))) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error - "expected a list of lists argument")) - (format:format-work iteration-str sublist))))) - ((rest-args) - (let* ((args (rest-args)) - (args-len (length args)) - (usedup-args - (do ((arg-pos 0 (+ arg-pos - (format:format-work - iteration-str - (list-tail - args arg-pos)))) - (i 0 (+ i 1))) - ((or (>= arg-pos args-len) - (and format:iteration-bounded - (>= i max-iterations))) - arg-pos)))) - (add-arg-pos usedup-args))) - ((rest-sublists) - (let* ((args (rest-args)) - (args-len (length args)) - (usedup-args - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (and format:iteration-bounded - (>= arg-pos max-iterations))) - arg-pos) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error "expected list arguments")) - (format:format-work iteration-str sublist))))) - (add-arg-pos usedup-args))) - (else (format:error "internal error in ~~}"))))) - (anychar-dispatch)) - ((#\^) ; Up and out - (let* ((continue - (cond - ((not (null? params)) - (not - (case (length params) - ((1) (zero? (car params))) - ((2) (= (list-ref params 0) (list-ref params 1))) - ((3) (<= (list-ref params 0) - (list-ref params 1) - (list-ref params 2))) - (else (format:error "too much parameters"))))) - (format:case-conversion ; if conversion stop conversion - (set! format:case-conversion string-copy) #t) - ((= iteration-nest 1) #t) - ((= conditional-nest 1) #t) - ((>= arg-pos arg-len) - (set! format:pos format-string-len) #f) - (else #t)))) - (if continue - (anychar-dispatch)))) - - ;; format directive modifiers and parameters - - ((#\@) ; `@' modifier - (if (memq modifier '(at colon-at)) - (format:error "double `@' modifier")) - (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) - (tilde-dispatch)) - ((#\:) ; `:' modifier - (if (memq modifier '(colon colon-at)) - (format:error "double `:' modifier")) - (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) - (tilde-dispatch)) - ((#\') ; Character parameter - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (char->integer (next-char))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr - (if modifier (format:error "misplaced modifier")) - (let ((num-str-beg (- format:pos 1)) - (num-str-end format:pos)) - (do ((ch (peek-next-char) (peek-next-char))) - ((not (char-numeric? ch))) - (next-char) - (set! num-str-end (+ 1 num-str-end))) - (set! params - (append params - (list (string->number - (substring format-string - num-str-beg - num-str-end)))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\V) ; Variable parameter from next argum. - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (next-arg)))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\#) ; Parameter is number of remaining args - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (length (rest-args))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\,) ; Parameter separators - (if modifier (format:error "misplaced modifier")) - (if (not param-value-found) - (set! params (append params '(#f)))) ; append empty paramtr - (set! param-value-found #f) - (tilde-dispatch)) - ((#\Q) ; Inquiry messages - (if (eq? modifier 'colon) - (format:out-str format:version) - (let ((nl (string #\newline))) - (format:out-str - (string-append - "SLIB Common LISP format version " format:version nl - " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl - " please send bug reports to `lutzeb@cs.tu-berlin.de'" - nl)))) - (anychar-dispatch)) - (else ; Unknown tilde directive - (format:error "unknown control character `~c'" - (string-ref format-string (- format:pos 1)))))) - (else (anychar-dispatch)))))) ; in case of conditional - - (set! format:pos 0) - (set! format:arg-pos 0) - (anychar-dispatch) ; start the formatting - (set! format:pos recursive-pos-save) - arg-pos)) ; return the position in the arg. list - -;; format:obj->str returns a R4RS representation as a string of an arbitrary -;; scheme object. -;; First parameter is the object, second parameter is a boolean if the -;; representation should be slashified as `write' does. -;; It uses format:char->str which converts a character into -;; a slashified string as `write' does and which is implementation dependent. -;; It uses format:iobj->str to print out internal objects as -;; quoted strings so that the output can always be processed by (read) - -(define (format:obj->str obj slashify) +;; First parameter is the object, second parameter is a boolean if +;; the representation should be slashified as `write' does. + +;; It uses format:char->str which converts a character into a +;; slashified string as `write' does and which is implementation +;; dependent. + +;; It uses format:iobj->str to print out internal objects as quoted +;; strings so that the output can always be processed by (read) + +;; If format:read-proof is set to #t the resulting string is +;; additionally set into string quotes. + +(define (format:obj->str obj slashify format:read-proof) (cond ((string? obj) (if slashify (let ((obj-len (string-length obj))) (string-append "\"" - (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm + (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm (if (= j obj-len) (string-append (substring obj i j) "\"") (let ((c (string-ref obj j))) @@ -820,43 +1516,44 @@ ((null? obj) "()") ((input-port? obj) - (format:iobj->str obj)) + (format:iobj->str obj format:read-proof)) ((output-port? obj) - (format:iobj->str obj)) + (format:iobj->str obj format:read-proof)) ((list? obj) (string-append "(" (let loop ((obj-list obj)) (if (null? (cdr obj-list)) - (format:obj->str (car obj-list) #t) + (format:obj->str (car obj-list) #t format:read-proof) (string-append - (format:obj->str (car obj-list) #t) + (format:obj->str (car obj-list) #t format:read-proof) " " (loop (cdr obj-list))))) ")")) ((pair? obj) (string-append "(" - (format:obj->str (car obj) #t) + (format:obj->str (car obj) #t format:read-proof) " . " - (format:obj->str (cdr obj) #t) + (format:obj->str (cdr obj) #t format:read-proof) ")")) ((vector? obj) - (string-append "#" (format:obj->str (vector->list obj) #t))) + (string-append "#" (format:obj->str (vector->list obj) #t format:read-proof))) (else ; only objects with an #<...> - (format:iobj->str obj)))) ; representation should fall in here + (format:iobj->str obj format:read-proof)))) + ; representation should fall in here -;; format:iobj->str reveals the implementation dependent representation of -;; #<...> objects with the use of display and call-with-output-string. -;; If format:read-proof is set to #t the resulting string is additionally -;; set into string quotes. +;; format:iobj->str reveals the implementation dependent +;; representation of #<...> objects with the use of display and +;; call-with-output-string. -(define format:read-proof #f) +;; If format:read-proof is set to #t the resulting string is +;; additionally set into string quotes. -(define (format:iobj->str iobj) +(define (format:iobj->str iobj format:read-proof) (if (or format:read-proof format:iobj-case-conv) (string-append @@ -868,11 +1565,22 @@ (if format:read-proof "\"" "")) (call-with-output-string (lambda (p) (display iobj p))))) +(define (format:par pars length index default name) + (if (> length index) + (let ((par (list-ref pars index))) + (if par + (if name + (if (< par 0) + (slib:error name "parameter must be a positive integer") + par) + par) + default)) + default)) ;; format:char->str converts a character into a slashified string as ;; done by `write'. The procedure is dependent on the integer -;; representation of characters and assumes a character number according to -;; the ASCII character set. +;; representation of characters and assumes a character number +;; according to the ASCII character set. (define (format:char->str ch) (let ((int-rep (char->integer ch))) @@ -885,763 +1593,29 @@ ((and (>= int-rep 0) (<= int-rep 32)) (vector-ref format:ascii-non-printable-charnames int-rep)) ((= int-rep 127) "del") - ((>= int-rep 128) ; octal representation + ((>= int-rep 128) ; octal representation (if format:radix-pref (let ((s (number->string int-rep 8))) (substring s 2 (string-length s))) (number->string int-rep 8))) (else (string ch)))))) -(define format:space-ch (char->integer #\space)) -(define format:zero-ch (char->integer #\0)) - -(define (format:par pars length index default name) - (if (> length index) - (let ((par (list-ref pars index))) - (if par - (if name - (if (< par 0) - (format:error - "~s parameter must be a positive integer" name) - par) - par) - default)) - default)) - -(define (format:out-obj-padded pad-left obj slashify pars) - (if (null? pars) - (format:out-str (format:obj->str obj slashify)) - (let ((l (length pars))) - (let ((mincol (format:par pars l 0 0 "mincol")) - (colinc (format:par pars l 1 1 "colinc")) - (minpad (format:par pars l 2 0 "minpad")) - (padchar (integer->char - (format:par pars l 3 format:space-ch #f))) - (objstr (format:obj->str obj slashify))) - (if (not pad-left) - (format:out-str objstr)) - (do ((objstr-len (string-length objstr)) - (i minpad (+ i colinc))) - ((>= (+ objstr-len i) mincol) - (format:out-fill i padchar))) - (if pad-left - (format:out-str objstr)))))) - -(define (format:out-num-padded modifier number pars radix) - (if (not (integer? number)) (format:error "argument not an integer")) - (let ((numstr (number->string number radix))) - (if (and format:radix-pref (not (= radix 10))) - (set! numstr (substring numstr 2 (string-length numstr)))) - (if (and (null? pars) (not modifier)) - (format:out-str numstr) - (let ((l (length pars)) - (numstr-len (string-length numstr))) - (let ((mincol (format:par pars l 0 #f "mincol")) - (padchar (integer->char - (format:par pars l 1 format:space-ch #f))) - (commachar (integer->char - (format:par pars l 2 (char->integer #\,) #f))) - (commawidth (format:par pars l 3 3 "commawidth"))) - (if mincol - (let ((numlen numstr-len)) ; calc. the output len of number - (if (and (memq modifier '(at colon-at)) (> number 0)) - (set! numlen (+ numlen 1))) - (if (memq modifier '(colon colon-at)) - (set! numlen (+ (quotient (- numstr-len - (if (< number 0) 2 1)) - commawidth) - numlen))) - (if (> mincol numlen) - (format:out-fill (- mincol numlen) padchar)))) - (if (and (memq modifier '(at colon-at)) - (> number 0)) - (format:out-char #\+)) - (if (memq modifier '(colon colon-at)) ; insert comma character - (let ((start (remainder numstr-len commawidth)) - (ns (if (< number 0) 1 0))) - (format:out-substr numstr 0 start) - (do ((i start (+ i commawidth))) - ((>= i numstr-len)) - (if (> i ns) - (format:out-char commachar)) - (format:out-substr numstr i (+ i commawidth)))) - (format:out-str numstr))))))) - -(define (format:tabulate modifier pars) - (let ((l (length pars))) - (let ((colnum (format:par pars l 0 1 "colnum")) - (colinc (format:par pars l 1 1 "colinc")) - (padch (integer->char (format:par pars l 2 format:space-ch #f)))) - (case modifier - ((colon colon-at) - (format:error "unsupported modifier for ~~t")) - ((at) ; relative tabulation - (format:out-fill - (if (= colinc 0) - colnum ; colnum = colrel - (do ((c 0 (+ c colinc)) - (col (+ format:output-col colnum))) - ((>= c col) - (- c format:output-col)))) - padch)) - (else ; absolute tabulation - (format:out-fill - (cond - ((< format:output-col colnum) - (- colnum format:output-col)) - ((= colinc 0) - 0) - (else - (do ((c colnum (+ c colinc))) - ((>= c format:output-col) - (- c format:output-col))))) - padch)))))) - - -;; roman numerals (from dorai@cs.rice.edu). - -(define format:roman-alist - '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) - (10 #\X) (5 #\V) (1 #\I))) - -(define format:roman-boundary-values - '(100 100 10 10 1 1 #f)) - -(define format:num->old-roman - (lambda (n) - (if (and (integer? n) (>= n 1)) - (let loop ((n n) - (romans format:roman-alist) - (s '())) - (if (null? romans) (list->string (reverse s)) - (let ((roman-val (caar romans)) - (roman-dgt (cadar romans))) - (do ((q (quotient n roman-val) (- q 1)) - (s s (cons roman-dgt s))) - ((= q 0) - (loop (remainder n roman-val) - (cdr romans) s)))))) - (format:error "only positive integers can be romanized")))) - -(define format:num->roman - (lambda (n) - (if (and (integer? n) (> n 0)) - (let loop ((n n) - (romans format:roman-alist) - (boundaries format:roman-boundary-values) - (s '())) - (if (null? romans) - (list->string (reverse s)) - (let ((roman-val (caar romans)) - (roman-dgt (cadar romans)) - (bdry (car boundaries))) - (let loop2 ((q (quotient n roman-val)) - (r (remainder n roman-val)) - (s s)) - (if (= q 0) - (if (and bdry (>= r (- roman-val bdry))) - (loop (remainder r bdry) (cdr romans) - (cdr boundaries) - (cons roman-dgt - (append - (cdr (assv bdry romans)) - s))) - (loop r (cdr romans) (cdr boundaries) s)) - (loop2 (- q 1) r (cons roman-dgt s))))))) - (format:error "only positive integers can be romanized")))) - -;; cardinals & ordinals (from dorai@cs.rice.edu) - -(define format:cardinal-ones-list - '(#f "one" "two" "three" "four" "five" - "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" - "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" - "nineteen")) - -(define format:cardinal-tens-list - '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" - "ninety")) - -(define format:num->cardinal999 - (lambda (n) - ;this procedure is inspired by the Bruno Haible's CLisp - ;function format-small-cardinal, which converts numbers - ;in the range 1 to 999, and is used for converting each - ;thousand-block in a larger number - (let* ((hundreds (quotient n 100)) - (tens+ones (remainder n 100)) - (tens (quotient tens+ones 10)) - (ones (remainder tens+ones 10))) - (append - (if (> hundreds 0) - (append - (string->list - (list-ref format:cardinal-ones-list hundreds)) - (string->list" hundred") - (if (> tens+ones 0) '(#\space) '())) - '()) - (if (< tens+ones 20) - (if (> tens+ones 0) - (string->list - (list-ref format:cardinal-ones-list tens+ones)) - '()) - (append - (string->list - (list-ref format:cardinal-tens-list tens)) - (if (> ones 0) - (cons #\- - (string->list - (list-ref format:cardinal-ones-list ones))) - '()))))))) - -(define format:cardinal-thousand-block-list - '("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion" " undecillion" " duodecillion" " tredecillion" - " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" - " octodecillion" " novemdecillion" " vigintillion")) - -(define format:num->cardinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "only integers can be converted to English cardinals")) - ((= n 0) "zero") - ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) - (else - (let ((power3-word-limit - (length format:cardinal-thousand-block-list))) - (let loop ((n n) - (power3 0) - (s '())) - (if (= n 0) - (list->string s) - (let ((n-before-block (quotient n 1000)) - (n-after-block (remainder n 1000))) - (loop n-before-block - (+ power3 1) - (if (> n-after-block 0) - (append - (if (> n-before-block 0) - (string->list ", ") '()) - (format:num->cardinal999 n-after-block) - (if (< power3 power3-word-limit) - (string->list - (list-ref - format:cardinal-thousand-block-list - power3)) - (append - (string->list " times ten to the ") - (string->list - (format:num->ordinal - (* power3 3))) - (string->list " power"))) - s) - s)))))))))) - -(define format:ordinal-ones-list - '(#f "first" "second" "third" "fourth" "fifth" - "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" - "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" - "eighteenth" "nineteenth")) - -(define format:ordinal-tens-list - '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" - "seventieth" "eightieth" "ninetieth")) - -(define format:num->ordinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "only integers can be converted to English ordinals")) - ((= n 0) "zeroth") - ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) - (else - (let ((hundreds (quotient n 100)) - (tens+ones (remainder n 100))) - (string-append - (if (> hundreds 0) - (string-append - (format:num->cardinal (* hundreds 100)) - (if (= tens+ones 0) "th" " ")) - "") - (if (= tens+ones 0) "" - (if (< tens+ones 20) - (list-ref format:ordinal-ones-list tens+ones) - (let ((tens (quotient tens+ones 10)) - (ones (remainder tens+ones 10))) - (if (= ones 0) - (list-ref format:ordinal-tens-list tens) - (string-append - (list-ref format:cardinal-tens-list tens) - "-" - (list-ref format:ordinal-ones-list ones)))) - )))))))) - -;; format fixed flonums (~F) - -(define (format:out-fixed modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((width (format:par pars l 0 #f "width")) - (digits (format:par pars l 1 #f "digits")) - (scale (format:par pars l 2 0 #f)) - (overch (format:par pars l 3 #f #f)) - (padch (format:par pars l 4 format:space-ch #f))) - - (if digits - - (begin ; fixed precision - (format:parse-float - (if (string? number) number (number->string number)) #t scale) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (if width - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (and (= format:fn-dot 0) (> width (+ digits 1))) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (format:out-fill (- width numlen) (integer->char padch))) - (if (and overch (> numlen width)) - (format:out-fill width (integer->char overch)) - (format:fn-out modifier (> width (+ digits 1))))) - (format:fn-out modifier #t))) - - (begin ; free precision - (format:parse-float - (if (string? number) number (number->string number)) #t scale) - (format:fn-strip) - (if width - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (= format:fn-dot 0) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (format:out-fill (- width numlen) (integer->char padch))) - (if (> numlen width) ; adjust precision if possible - (let ((dot-index (- numlen - (- format:fn-len format:fn-dot)))) - (if (> dot-index width) - (if overch ; numstr too big for required width - (format:out-fill width (integer->char overch)) - (format:fn-out modifier #t)) - (begin - (format:fn-round (- width dot-index)) - (format:fn-out modifier #t)))) - (format:fn-out modifier #t))) - (format:fn-out modifier #t))))))) - -;; format exponential flonums (~E) - -(define (format:out-expon modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number")) - - (let ((l (length pars))) - (let ((width (format:par pars l 0 #f "width")) - (digits (format:par pars l 1 #f "digits")) - (edigits (format:par pars l 2 #f "exponent digits")) - (scale (format:par pars l 3 1 #f)) - (overch (format:par pars l 4 #f #f)) - (padch (format:par pars l 5 format:space-ch #f)) - (expch (format:par pars l 6 #f #f))) - - (if digits ; fixed precision - - (let ((digits (if (> scale 0) - (if (< scale (+ digits 2)) - (+ (- digits scale) 1) - 0) - digits))) - (format:parse-float - (if (string? number) number (number->string number)) #f scale) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (if width - (if (and edigits overch (> format:en-len edigits)) - (format:out-fill width (integer->char overch)) - (let ((numlen (+ format:fn-len 3))) ; .E+ - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (and (= format:fn-dot 0) (> width (+ digits 1))) - (set! numlen (+ numlen 1))) - (set! numlen - (+ numlen - (if (and edigits (>= edigits format:en-len)) - edigits - format:en-len))) - (if (< numlen width) - (format:out-fill (- width numlen) - (integer->char padch))) - (if (and overch (> numlen width)) - (format:out-fill width (integer->char overch)) - (begin - (format:fn-out modifier (> width (- numlen 1))) - (format:en-out edigits expch))))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch)))) - - (begin ; free precision - (format:parse-float - (if (string? number) number (number->string number)) #f scale) - (format:fn-strip) - (if width - (if (and edigits overch (> format:en-len edigits)) - (format:out-fill width (integer->char overch)) - (let ((numlen (+ format:fn-len 3))) ; .E+ - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (= format:fn-dot 0) - (set! numlen (+ numlen 1))) - (set! numlen - (+ numlen - (if (and edigits (>= edigits format:en-len)) - edigits - format:en-len))) - (if (< numlen width) - (format:out-fill (- width numlen) - (integer->char padch))) - (if (> numlen width) ; adjust precision if possible - (let ((f (- format:fn-len format:fn-dot))) ; fract len - (if (> (- numlen f) width) - (if overch ; numstr too big for required width - (format:out-fill width - (integer->char overch)) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch))) - (begin - (format:fn-round (+ (- f numlen) width)) - (format:fn-out modifier #t) - (format:en-out edigits expch)))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch))))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch)))))))) - -;; format general flonums (~G) - -(define (format:out-general modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((width (if (> l 0) (list-ref pars 0) #f)) - (digits (if (> l 1) (list-ref pars 1) #f)) - (edigits (if (> l 2) (list-ref pars 2) #f)) - (overch (if (> l 4) (list-ref pars 4) #f)) - (padch (if (> l 5) (list-ref pars 5) #f))) - (format:parse-float - (if (string? number) number (number->string number)) #t 0) - (format:fn-strip) - (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm - (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 - (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? - (- (format:fn-zlead)) - format:fn-dot)) - (d (if digits - digits - (max format:fn-len (min n 7)))) ; q = format:fn-len - (dd (- d n))) - (if (<= 0 dd d) - (begin - (format:out-fixed modifier number (list ww dd #f overch padch)) - (format:out-fill ee #\space)) ;~@T not implemented yet - (format:out-expon modifier number pars)))))) - -;; format dollar flonums (~$) - -(define (format:out-dollar modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((digits (format:par pars l 0 2 "digits")) - (mindig (format:par pars l 1 1 "mindig")) - (width (format:par pars l 2 0 "width")) - (padch (format:par pars l 3 format:space-ch #f))) - - (format:parse-float - (if (string? number) number (number->string number)) #t 0) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) - (set! numlen (+ numlen 1))) - (if (and mindig (> mindig format:fn-dot)) - (set! numlen (+ numlen (- mindig format:fn-dot)))) - (if (and (= format:fn-dot 0) (not mindig)) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (case modifier - ((colon) - (if (not format:fn-pos?) - (format:out-char #\-)) - (format:out-fill (- width numlen) (integer->char padch))) - ((at) - (format:out-fill (- width numlen) (integer->char padch)) - (format:out-char (if format:fn-pos? #\+ #\-))) - ((colon-at) - (format:out-char (if format:fn-pos? #\+ #\-)) - (format:out-fill (- width numlen) (integer->char padch))) - (else - (format:out-fill (- width numlen) (integer->char padch)) - (if (not format:fn-pos?) - (format:out-char #\-)))) - (if format:fn-pos? - (if (memq modifier '(at colon-at)) (format:out-char #\+)) - (format:out-char #\-)))) - (if (and mindig (> mindig format:fn-dot)) - (format:out-fill (- mindig format:fn-dot) #\0)) - (if (and (= format:fn-dot 0) (not mindig)) - (format:out-char #\0)) - (format:out-substr format:fn-str 0 format:fn-dot) - (format:out-char #\.) - (format:out-substr format:fn-str format:fn-dot format:fn-len)))) - -; the flonum buffers - -(define format:fn-max 200) ; max. number of number digits -(define format:fn-str (make-string format:fn-max)) ; number buffer -(define format:fn-len 0) ; digit length of number -(define format:fn-dot #f) ; dot position of number -(define format:fn-pos? #t) ; number positive? -(define format:en-max 10) ; max. number of exponent digits -(define format:en-str (make-string format:en-max)) ; exponent buffer -(define format:en-len 0) ; digit length of exponent -(define format:en-pos? #t) ; exponent positive? - -(define (format:parse-float num-str fixed? scale) - (set! format:fn-pos? #t) - (set! format:fn-len 0) - (set! format:fn-dot #f) - (set! format:en-pos? #t) - (set! format:en-len 0) - (do ((i 0 (+ i 1)) - (left-zeros 0) - (mantissa? #t) - (all-zeros? #t) - (num-len (string-length num-str)) - (c #f)) ; current exam. character in num-str - ((= i num-len) - (if (not format:fn-dot) - (set! format:fn-dot format:fn-len)) - - (if all-zeros? - (begin - (set! left-zeros 0) - (set! format:fn-dot 0) - (set! format:fn-len 1))) - - ;; now format the parsed values according to format's need - - (if fixed? - - (begin ; fixed format m.nnn or .nnn - (if (and (> left-zeros 0) (> format:fn-dot 0)) - (if (> format:fn-dot left-zeros) - (begin ; norm 0{0}nn.mm to nn.mm - (format:fn-shiftleft left-zeros) - (set! left-zeros 0) - (set! format:fn-dot (- format:fn-dot left-zeros))) - (begin ; normalize 0{0}.nnn to .nnn - (format:fn-shiftleft format:fn-dot) - (set! left-zeros (- left-zeros format:fn-dot)) - (set! format:fn-dot 0)))) - (if (or (not (= scale 0)) (> format:en-len 0)) - (let ((shift (+ scale (format:en-int)))) - (cond - (all-zeros? #t) - ((> (+ format:fn-dot shift) format:fn-len) - (format:fn-zfill - #f (- shift (- format:fn-len format:fn-dot))) - (set! format:fn-dot format:fn-len)) - ((< (+ format:fn-dot shift) 0) - (format:fn-zfill #t (- (- shift) format:fn-dot)) - (set! format:fn-dot 0)) - (else - (if (> left-zeros 0) - (if (<= left-zeros shift) ; shift always > 0 here - (format:fn-shiftleft shift) ; shift out 0s - (begin - (format:fn-shiftleft left-zeros) - (set! format:fn-dot (- shift left-zeros)))) - (set! format:fn-dot (+ format:fn-dot shift)))))))) - - (let ((negexp ; expon format m.nnnEee - (if (> left-zeros 0) - (- left-zeros format:fn-dot -1) - (if (= format:fn-dot 0) 1 0)))) - (if (> left-zeros 0) - (begin ; normalize 0{0}.nnn to n.nn - (format:fn-shiftleft left-zeros) - (set! format:fn-dot 1)) - (if (= format:fn-dot 0) - (set! format:fn-dot 1))) - (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) - negexp)) - (cond - (all-zeros? - (format:en-set 0) - (set! format:fn-dot 1)) - ((< scale 0) ; leading zero - (format:fn-zfill #t (- scale)) - (set! format:fn-dot 0)) - ((> scale format:fn-dot) - (format:fn-zfill #f (- scale format:fn-dot)) - (set! format:fn-dot scale)) - (else - (set! format:fn-dot scale))))) - #t) - - ;; do body - (set! c (string-ref num-str i)) ; parse the output of number->string - (cond ; which can be any valid number - ((char-numeric? c) ; representation of R4RS except - (if mantissa? ; complex numbers - (begin - (if (char=? c #\0) - (if all-zeros? - (set! left-zeros (+ left-zeros 1))) - (begin - (set! all-zeros? #f))) - (string-set! format:fn-str format:fn-len c) - (set! format:fn-len (+ format:fn-len 1))) - (begin - (string-set! format:en-str format:en-len c) - (set! format:en-len (+ format:en-len 1))))) - ((or (char=? c #\-) (char=? c #\+)) - (if mantissa? - (set! format:fn-pos? (char=? c #\+)) - (set! format:en-pos? (char=? c #\+)))) - ((char=? c #\.) - (set! format:fn-dot format:fn-len)) - ((char=? c #\e) - (set! mantissa? #f)) - ((char=? c #\E) - (set! mantissa? #f)) - ((char-whitespace? c) #t) - ((char=? c #\d) #t) ; decimal radix prefix - ((char=? c #\#) #t) - (else - (format:error "illegal character `~c' in number->string" c))))) - -(define (format:en-int) ; convert exponent string to integer - (if (= format:en-len 0) - 0 - (do ((i 0 (+ i 1)) - (n 0)) - ((= i format:en-len) - (if format:en-pos? - n - (- n))) - (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) - format:zero-ch)))))) - -(define (format:en-set en) ; set exponent string number - (set! format:en-len 0) - (set! format:en-pos? (>= en 0)) - (let ((en-str (number->string en))) - (do ((i 0 (+ i 1)) - (en-len (string-length en-str)) - (c #f)) - ((= i en-len)) - (set! c (string-ref en-str i)) - (if (char-numeric? c) - (begin - (string-set! format:en-str format:en-len c) - (set! format:en-len (+ format:en-len 1))))))) - -(define (format:fn-zfill left? n) ; fill current number string with 0s - (if (> (+ n format:fn-len) format:fn-max) ; from the left or right - (format:error "number is too long to format (enlarge format:fn-max)")) - (set! format:fn-len (+ format:fn-len n)) - (if left? - (do ((i format:fn-len (- i 1))) ; fill n 0s to left - ((< i 0)) - (string-set! format:fn-str i - (if (< i n) - #\0 - (string-ref format:fn-str (- i n))))) - (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right - ((= i format:fn-len)) - (string-set! format:fn-str i #\0)))) - -(define (format:fn-shiftleft n) ; shift left current number n positions - (if (> n format:fn-len) - (format:error "internal error in format:fn-shiftleft (~d,~d)" - n format:fn-len)) - (do ((i n (+ i 1))) - ((= i format:fn-len) - (set! format:fn-len (- format:fn-len n))) - (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))) - -(define (format:fn-round digits) ; round format:fn-str - (set! digits (+ digits format:fn-dot)) - (do ((i digits (- i 1)) ; "099",2 -> "10" - (c 5)) ; "023",2 -> "02" - ((or (= c 0) (< i 0)) ; "999",2 -> "100" - (if (= c 1) ; "005",2 -> "01" - (begin ; carry overflow - (set! format:fn-len digits) - (format:fn-zfill #t 1) ; add a 1 before fn-str - (string-set! format:fn-str 0 #\1) - (set! format:fn-dot (+ format:fn-dot 1))) - (set! format:fn-len digits))) - (set! c (+ (- (char->integer (string-ref format:fn-str i)) - format:zero-ch) c)) - (string-set! format:fn-str i (integer->char - (if (< c 10) - (+ c format:zero-ch) - (+ (- c 10) format:zero-ch)))) - (set! c (if (< c 10) 0 1)))) - -(define (format:fn-out modifier add-leading-zero?) - (if format:fn-pos? - (if (eq? modifier 'at) - (format:out-char #\+)) - (format:out-char #\-)) - (if (= format:fn-dot 0) - (if add-leading-zero? - (format:out-char #\0)) - (format:out-substr format:fn-str 0 format:fn-dot)) - (format:out-char #\.) - (format:out-substr format:fn-str format:fn-dot format:fn-len)) - -(define (format:en-out edigits expch) - (format:out-char (if expch (integer->char expch) format:expch)) - (format:out-char (if format:en-pos? #\+ #\-)) - (if edigits - (if (< format:en-len edigits) - (format:out-fill (- edigits format:en-len) #\0))) - (format:out-substr format:en-str 0 format:en-len)) - -(define (format:fn-strip) ; strip trailing zeros but one - (string-set! format:fn-str format:fn-len #\0) - (do ((i format:fn-len (- i 1))) - ((or (not (char=? (string-ref format:fn-str i) #\0)) - (<= i format:fn-dot)) - (set! format:fn-len (+ i 1))))) - -(define (format:fn-zlead) ; count leading zeros - (do ((i 0 (+ i 1))) - ((or (= i format:fn-len) - (not (char=? (string-ref format:fn-str i) #\0))) - (if (= i format:fn-len) ; found a real zero - 0 - i)))) - +;;; We should keep separate track of columns for each port, but +;;; keeping pointers to ports will foil GC. Instead, keep +;;; associations indexed by the DISPLAYed representation of the ports. +(define *port-columns* '()) +(define (format:get-port-column port) + (define pair (assoc (call-with-output-string + (lambda (sport) (display port sport))) + *port-columns*)) + (if pair (cdr pair) 0)) +(define (format:set-port-column! port col) + (define pname (call-with-output-string + (lambda (sport) (display port sport)))) + (let ((pair (assoc pname *port-columns*))) + (if pair + (set-cdr! pair col) + (set! *port-columns* (cons (cons pname col) *port-columns*))))) ;;; some global functions not found in SLIB @@ -1658,31 +1632,3 @@ (begin (set! non-first-alpha #t) (string-set! cap-str i (char-upcase c))))))))) - -(define (format:list-head l k) - (if (= k 0) - '() - (cons (car l) (format:list-head (cdr l) (- k 1))))) - - -;; Aborts the program when a formatting error occures. This is a null -;; argument closure to jump to the interpreters toplevel continuation. - -(define format:abort (lambda () (slib:error "error in format"))) - -(define format format:format) - -;; If this is not possible then a continuation is used to recover -;; properly from a format error. In this case format returns #f. - -;(define format:abort -; (lambda () (format:error-continuation #f))) - -;(define format -; (lambda args ; wraps format:format with an error -; (call-with-current-continuation ; continuation -; (lambda (cont) -; (set! format:error-continuation cont) -; (apply format:format args))))) - -;eof |