#| TODO:

* more tests

- tests of format with #f, #t, or port as first argument; test of printf

and fprintf, tests that exercise all paths of cp1in format handler

- verify complete coverage of code paths

- extract all tests from cltl2

- more # and v parameter tests

- ~^ tests:

- need tests for outside abort, abort in indirect, nested {super-,}abort

in conditionals, nested {super-,}abort in case-conversion, etc.

- need tests with one parameter and two parameters

- ~* and ~:p tests for moving around loop args

- test float printing with Bob's set of floats

* use something better than string-append for constructing ~f and ~e output

* use more efficient dispatch, e.g., have case use binary search for fixnum

keys; or modify compiler to use jump tables for well-behaved case's

* look into not hardcoding float-base = 10

* vparams adds substantial allocation overhead, probably because of the

compiler's handling of mvlet producers containing if expressions; fix

the compiler

* abstract out Chez Scheme specifics, like display-string, $list-length,

string ports, use of generic port

|#

(let ()

;;; configuration

;; check for too many args at parse time

(define static-too-many-args-check #t)

;; check for too many args at parse time for indirects and loop bodies

(define indirect-too-many-args-check #f)

;; check for too many args at run time. the check is always suppressed

;; when we terminate a format or indirect format as the result of ~^

(define dynamic-too-many-args-check #f)

;;; predicates used to check format parameters

(define nnfixnum? (lambda (x) (and (fixnum? x) (fx>= x 0))))

(define true? (lambda (x) #t))

(define pfixnum? (lambda (x) (and (fixnum? x) (fx> x 0))))

(define radix? (lambda (x) (and (fixnum? x) (fx<= 2 x 36))))

; we require nongenerative records because the compiler embeds parsed

; format strings in object files. force cp1in-parse-format to return #f

; to bootstrap after making changes to any of these records

(define-datatype (#{fmt cgos0c9ufi1rq-fd} (immutable directive))

(#{newline cgos0c9ufi1rq-ez} n)

(#{fresh-line cgos0c9ufi1rq-fc} n)

(#{dup-char cgos0c9ufi1rq-fh} n c)

(#{display cgos0c9ufi1rq-fi} mincol colinc minpad pad-char left?)

(#{simple-display cgos0c9ufi1rq-et})

(#{simple-write cgos0c9ufi1rq-es})

(#{write cgos0c9ufi1rq-ei} mincol colinc minpad pad-char nogensym? left?)

(#{cwrite cgos0c9ufi1rq-fk} colon? at?)

(#{fwrite cgos0c9ufi1rq-fb} w d k oc pc sign?)

(#{ewrite cgos0c9ufi1rq-ff} w d ew k oc pc ec sign?)

(#{gwrite cgos0c9ufi1rq-e9} w d ew k oc pc ec sign?)

(#{$write cgos0c9ufi1rq-eg} d n w pc sign-before-pad? sign?)

(#{write-radix cgos0c9ufi1rq-eh} base w pc cc ci sign? commas?)

(#{plural cgos0c9ufi1rq-ey} back-up? y/ies?)

(#{fancy-radix cgos0c9ufi1rq-fe} colon? at?)

(#{indirect cgos0c9ufi1rq-e6} splice?)

(#{goto cgos0c9ufi1rq-fa} n reverse? absolute?)

(#{tabulate cgos0c9ufi1rq-ek} colnum colinc relative?)

(#{convert-case cgos0c9ufi1rq-fl} nested-cmd* colon? at?)

(#{conditional cgos0c9ufi1rq-fo} n cases default)

(#{conditional/at cgos0c9ufi1rq-fn} consequent)

(#{conditional/colon cgos0c9ufi1rq-fm} alternative consequent)

(#{justify cgos0c9ufi1rq-e1} mincol colinc minpad pad-char before? after? initial margin columns segments)

(#{abort cgos0c9ufi1rq-ft} n m super?)

(#{iteration cgos0c9ufi1rq-e2} body n sublists? use-remaining? at-least-once?)

(#{columntrack cgos0c9ufi1rq-fq} body)

)

;;; parse string to list of strings, chars, and fmt records

(define parse

(lambda (who cntl)

(define column? #f)

(define-syntactic-monad state nargs cmd* stack)

(define-record-type frame

(fields (immutable directive) (immutable cmd*))

(nongenerative))

(define-record-type cvtcase-frame

(parent frame)

(fields (immutable colon?) (immutable at?))

(nongenerative)

(sealed #t))

(define-record-type conditional/at-frame

(parent frame)

(nongenerative)

(sealed #t))

(define-record-type conditional/colon-frame

(parent frame)

(fields (mutable altern))

(nongenerative)

(sealed #t)

(protocol

(lambda (make-new)

(lambda (directive cmd*)

((make-new directive cmd*) #f)))))

(define-record-type conditional-frame

(parent frame)

(fields (immutable n) (mutable cases) (mutable default?))

(nongenerative)

(sealed #t)

(protocol

(lambda (make-new)

(lambda (directive cmd* n)

((make-new directive cmd*) n '() #f)))))

(define-record-type justify-frame

(parent frame)

(fields

(immutable mincol)

(immutable colinc)

(immutable minpad)

(immutable pc)

(immutable before?)

(immutable after?)

(mutable segments)

(mutable initial)

(mutable margin)

(mutable columns))

(nongenerative)

(sealed #t)

(protocol

(lambda (make-new)

(lambda (directive cmd* mincol colinc minpad pc before? after?)

((make-new directive cmd*) mincol colinc minpad pc before? after? '() #f #f #f)))))

(define-record-type iteration-frame

(parent frame)

(fields (immutable n) (immutable sublists?) (immutable use-remaining?))

(nongenerative)

(sealed #t))

(define incomplete-format-directive

(lambda (b i)

($oops who "incomplete format directive ~s"

(substring cntl b i))))

(define (bump x n) (and x n (fx+ x n)))

(unless (string? cntl)

($oops who "~s is not a string" cntl))

(let ([nmax (fx- (string-length cntl) 1)])

(define char

(lambda (i)

(if (fx> i nmax)

#!eof

(string-ref cntl i))))

(define sfinal

(state lambda ()

(unless (null? stack)

($oops who "unclosed directive ~a" (frame-directive (car stack))))

(let ([cmd* (reverse cmd*)])

(values (if column? (list (fmt-columntrack "" cmd*)) cmd*) nargs))))

(define s0

(state lambda (i)

(let ([c (char i)])

(state-case c

[eof (state sfinal ())]

[(#\~) (state s3 () (fx+ i 1) i)]

[else (state s1 () (fx+ i 1) i c)]))))

(define s1

(state lambda (i b c0)

(let ([c (char i)])

(state-case c

[eof (state sfinal ([cmd* (cons c0 cmd*)]))]

[(#\~) (state s3 ([cmd* (cons c0 cmd*)]) (fx+ i 1) i)]

[else (state s2 () (fx+ i 1) b)]))))

(define s2

(state lambda (i b)

(let ([c (char i)])

(state-case c

[eof (state sfinal ([cmd* (cons (substring cntl b i) cmd*)]))]

[(#\~) (state s3 ([cmd* (cons (substring cntl b i) cmd*)]) (fx+ i 1) i)]

[else (state s2 () (fx+ i 1) b)]))))

(define s3

(state lambda (i b)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[(#\~) (state s1 () (fx+ i 1) i #\~)]

[(#\- #\+) (state s4-sign () (fx+ i 1) b '() i)]

[((#\0 - #\9)) (state s4-digit () (fx+ i 1) b '() i)]

[(#\,) (state s4-comma () (fx+ i 1) b '(#f))]

[(#\') (state s4-quote () (fx+ i 1) b '())]

[(#\#) (state s4-after-param () (fx+ i 1) b '(hash))]

[(#\v) (state s4-after-param ([nargs (bump nargs 1)]) (fx+ i 1) b '(v))]

[else (state s5 () i b '())]))))

(define s4-sign

(state lambda (i b p* bp)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[((#\0 - #\9)) (state s4-digit () (fx+ i 1) b p* bp)]

[else (incomplete-format-directive b i)]))))

(define s4-quote

(state lambda (i b p*)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[else (state s4-after-param () (fx+ i 1) b (cons c p*))]))))

(define s4-after-param

(state lambda (i b p*)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[(#\,) (state s4-comma () (fx+ i 1) b p*)]

[else (state s5 () i b (reverse p*))]))))

(define s4-digit

(state lambda (i b p* bp)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[((#\0 - #\9)) (state s4-digit () (fx+ i 1) b p* bp)]

[(#\,) (state s4-comma () (fx+ i 1) b (cons (string->number (substring cntl bp i)) p*))]

[else (state s5 () i b (reverse (cons (string->number (substring cntl bp i)) p*)))]))))

(define s4-comma

(state lambda (i b p*)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[(#\- #\+) (state s4-sign () (fx+ i 1) b p* i)]

[((#\0 - #\9)) (state s4-digit () (fx+ i 1) b p* i)]

[(#\,) (state s4-comma () (fx+ i 1) b (cons #f p*))]

[(#\') (state s4-quote () (fx+ i 1) b p*)]

[(#\#) (state s4-after-param () (fx+ i 1) b (cons 'hash p*))]

[(#\v) (state s4-after-param ([nargs (bump nargs 1)]) (fx+ i 1) b (cons 'v p*))]

[else (state s5 () i b (reverse (cons #f p*)))]))))

(define s5

(state lambda (i b p*)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[(#\:) (state s5-colon () (fx+ i 1) b p*)]

[(#\@) (state s5-at () (fx+ i 1) b p*)]

[else (state s6 () i b p* #f #f)]))))

(define s5-colon

(state lambda (i b p*)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[(#\@) (state s6 () (fx+ i 1) b p* #t #t)]

[else (state s6 () i b p* #t #f)]))))

(define s5-at

(state lambda (i b p*)

(let ([c (char i)])

(state-case c

[eof (incomplete-format-directive b i)]

[(#\:) (state s6 () (fx+ i 1) b p* #t #t)]

[else (state s6 () i b p* #f #t)]))))

(define s6

(state lambda (i b p* colon? at?)

(define skip-non-newline-white

(lambda (i)

(let ([c (char i)])

(state-case c

[eof i]

[(#\space #\tab #\page #\return)

(skip-non-newline-white (fx+ i 1))]

[else i]))))

(let ([c (char i)])

(define no-colon

(lambda ()

(when colon?

($oops who "~~~c directive has no : flag" c))))

(define no-at

(lambda ()

(when at?

($oops who "~~~c directive has no @ flag" c))))

(define too-many-parameters

(lambda ()

($oops who

"too many parameters in ~~~c directive ~s"

c (substring cntl b (fx+ i 1)))))

(define missing-parameter

(lambda (what)

($oops who

"missing required ~s parameter in ~~~c directive ~s"

what c (substring cntl b (fx+ i 1)))))

(define invalid-parameter

(lambda (what arg)

($oops who

"invalid ~s parameter ~a in ~~~c directive ~s"

what arg c (substring cntl b (fx+ i 1)))))

(define misplaced-directive

(lambda ()

($oops who "misplaced directive ~s"

(substring cntl b (fx+ i 1)))))

(define-syntax parameters

(lambda (x)

(define process-param

(lambda (t* param* body)

(if (null? param*)

body

(with-syntax ([body (process-param (cdr t*) (cdr param*) body)]

[t (car t*)])

(syntax-case (car param*) (implicit)

[(implicit e) #'(let ([t e]) body)]

[(type? p)

#'(begin

(when (null? p*) (missing-parameter 'p))

(let ([t (car p*)] [p* (cdr p*)])

(when (not t) (missing-parameter 'p))

(unless (or (type? t) (memq t '(hash v))) (invalid-parameter 'p t))

body))]

[(type? p default)

#'(let ([proc (lambda (t p*) body)])

(if (null? p*)

(proc 'default p*)

(let ([t (car p*)] [p* (cdr p*)])

(if (not t)

(proc default p*)

(begin

(unless (or (type? t) (memq t '(hash v))) (invalid-parameter 'p t))

(proc t p*))))))])))))

(syntax-case x ()

[(_ ([t param] ...) e1 e2 ...)

(process-param

#'(t ...)

#'(param ...)

#'(begin

(unless (null? p*) (too-many-parameters))

(let () e1 e2 ...)))])))

(define-syntax directive

(lambda (x)

(define construct-name

(lambda (template-identifier . args)

(datum->syntax

template-identifier

(string->symbol

(apply string-append

(map (lambda (x)

(if (string? x)

x

(symbol->string (syntax->datum x))))

args))))))

(syntax-case x ()

[(k (d param ...) n)

(with-syntax ([(t ...) (generate-temporaries #'(param ...))]

[fmt-d (construct-name #'d "fmt-" #'d)])

(with-implicit (k state cmd* nargs)

#'(parameters ([t param] ...)

(state s0

([cmd* (cons (fmt-d (substring cntl b (fx+ i 1)) t ...) cmd*)]

[nargs (bump nargs n)])

(fx+ i 1)))))])))

(define-syntax parse-radix

(syntax-rules ()

[(_ base)

(directive

(write-radix [implicit base]

[nnfixnum? w #f]

[char? pad-char #\space]

[char? comma-char #\,]

[pfixnum? comma-interval 3]

[implicit at?]

[implicit colon?])

1)]))

(state-case c

[eof (incomplete-format-directive b i)]

[(#\% #\n #\N)

(no-at)

(no-colon)

(if (or (null? p*) (equal? p* '(1)))

(state s0 ([cmd* (cons #\newline cmd*)]) (fx+ i 1))

(directive (dup-char [nnfixnum? n 1] [implicit #\newline]) 0))]

[(#\&)

(no-at)

(no-colon)

(directive (fresh-line [nnfixnum? n 1]) 0)]

[(#\a #\A)

(no-colon)

(if (null? p*)

(directive

(simple-display)

1)

(directive

(display [nnfixnum? mincol 0]

[pfixnum? colinc 1]

[nnfixnum? minpad 0]

[char? pad-char #\space]

[implicit at?])

1))]

[(#\s #\S #\w #\W)

(if (and (null? p*) (not colon?))

(directive

(simple-write)

1)

(directive

(write [nnfixnum? mincol 0]

[pfixnum? colinc 1]

[nnfixnum? minpad 0]

[char? pad-char #\space]

[implicit colon?]

[implicit at?])

1))]

[(#\f #\F)

(no-colon)

(directive

(fwrite [nnfixnum? w #f]

[nnfixnum? d #f]

[fixnum? k 0]

[char? overflow-char #f]

[char? pad-char #\space]

[implicit at?])

1)]

[(#\e #\E)

(no-colon)

(directive

(ewrite [nnfixnum? w #f]

[nnfixnum? d #f]

[pfixnum? e #f]

[fixnum? k 1]

[char? overflow-char #f]

[char? pad-char #\space]

[char? exponent-char #\e]

[implicit at?])

1)]

[(#\g #\G)

(no-colon)

(directive

(gwrite [nnfixnum? w #f]

[nnfixnum? d #f]

[pfixnum? e #f]

[fixnum? k 1] ; assumption

[char? overflow-char #f]

[char? pad-char #\space]

[char? exponent-char #\e]

[implicit at?])

1)]

[(#\$)

(directive

($write [nnfixnum? d 2]

[nnfixnum? n 1]

[nnfixnum? w 0]

[char? pad-char #\space]

[implicit colon?]

[implicit at?])

1)]

[(#\c #\C)

(directive

(cwrite [implicit colon?] [implicit at?])

1)]

[(#\b #\B) (parse-radix 2)]

[(#\o #\O) (parse-radix 8)]

[(#\d #\D) (parse-radix 10)]

[(#\x #\X) (parse-radix 16)]

[(#\r #\R)

(if (null? p*)

(directive

(fancy-radix [implicit colon?] [implicit at?])

1)

(directive

(write-radix [radix? n 10]

[nnfixnum? w #f]

[char? pad-char #\space]

[char? comma-char #\,]

[pfixnum? comma-interval 3]

[implicit at?]

[implicit colon?])

1))]

[(#\p #\P)

(directive

(plural [implicit colon?] [implicit at?])

(if colon? 0 1))]

[(#\t #\T)

(no-colon)

(set! column? #t)

(directive

(tabulate [nnfixnum? colnum 1]

[nnfixnum? colinc 1]

[implicit at?])

0)]

[(#\?)

(no-colon)

(set! column? #t)

(directive

(indirect [implicit at?])

(if at? #f 2))]

[(#\*)

(when (and colon? at?)

($oops who

"@ and : modifiers are mutually exclusive for format directive ~~~c"

c))

(directive

(goto [nnfixnum? n #f] [implicit colon?] [implicit at?])

#f)]

[(#\( #|)|#)

(parameters ()

(state s0

([stack (cons (make-cvtcase-frame (substring cntl b (fx+ i 1)) cmd* colon? at?) stack)]

[cmd* '()])

(fx+ i 1)))]

[(#|(|# #\))

(no-at)

(no-colon)

(let ([x (and (not (null? stack)) (car stack))])

(unless (cvtcase-frame? x) (misplaced-directive))

(let ([nested-cmd* (reverse cmd*)])

(let ([stack (cdr stack)] [cmd* (frame-cmd* x)])

(directive

(convert-case [implicit nested-cmd*]

[implicit (cvtcase-frame-colon? x)]

[implicit (cvtcase-frame-at? x)])

0))))]

[(#\;)

(no-at)

(let ([x (and (not (null? stack)) (car stack))])

(cond

[(and (conditional/colon-frame? x)

(not colon?)

(not (conditional/colon-frame-altern x)))

(parameters ()

(conditional/colon-frame-altern-set! x (reverse cmd*)))

(state s0 ([cmd* '()]) (fx+ i 1))]

[(and (conditional-frame? x) (not (conditional-frame-default? x)))

(parameters ()

(when colon? (conditional-frame-default?-set! x #t))

(conditional-frame-cases-set! x

(cons (reverse cmd*) (conditional-frame-cases x))))

(state s0 ([cmd* '()]) (fx+ i 1))]

[(and (justify-frame? x)

(or (not colon?)

(and (not (justify-frame-initial x))

(null? (justify-frame-segments x)))))

(if colon?

(parameters ([margin (nnfixnum? n 0)]

[cols (nnfixnum? lw 72)])

(set! column? #t)

(justify-frame-initial-set! x (reverse cmd*))

(justify-frame-margin-set! x margin)

(justify-frame-columns-set! x cols))

(parameters ()

(justify-frame-segments-set! x

(cons (reverse cmd*) (justify-frame-segments x)))))

(state s0 ([cmd* '()]) (fx+ i 1))]

[else (misplaced-directive)]))]

[(#\^)

(no-at)

(directive

(abort [true? n #f] [true? m #f] [implicit colon?])

#f)]

[(#\{ #|}|#)

(when (null? cmd*) (set! column? #t))

(parameters ([n (nnfixnum? n #f)])

(state s0

([stack (cons (make-iteration-frame (substring cntl b (fx+ i 1)) cmd* n colon? at?) stack)]

[cmd* '()])

(fx+ i 1)))]

[(#|{|# #\})

(no-at)

(let ([x (and (not (null? stack)) (car stack))])

(unless (iteration-frame? x) (misplaced-directive))

(let ([nested-cmd* (reverse cmd*)])

(let ([stack (cdr stack)] [cmd* (frame-cmd* x)])

(directive

(iteration [implicit nested-cmd*]

[implicit (iteration-frame-n x)]

[implicit (iteration-frame-sublists? x)]

[implicit (iteration-frame-use-remaining? x)]

[implicit colon?])

#f))))]

[(#\[ #|]|#)

(if at?

(if colon?

($oops who "@ and : modifiers are mutually exclusive for format directive ~~~c" c)

(parameters ()

(state s0

([stack (cons (make-conditional/at-frame (substring cntl b (fx+ i 1)) cmd*) stack)]

[cmd* '()])

(fx+ i 1))))

(if colon?

(parameters ()

(state s0

([stack (cons (make-conditional/colon-frame (substring cntl b (fx+ i 1)) cmd*) stack)]

[cmd* '()])

(fx+ i 1)))

(parameters ([n (nnfixnum? n #f)])

(state s0

([stack (cons (make-conditional-frame (substring cntl b (fx+ i 1)) cmd* n) stack)]

[cmd* '()])

(fx+ i 1)))))]

[(#|[|# #\])

(no-at)

(no-colon)

(let ([x (and (not (null? stack)) (car stack))])

(let ([nested-cmd* (reverse cmd*)])

(cond

[(conditional/at-frame? x)

(let ([stack (cdr stack)] [cmd* (frame-cmd* x)])

(directive

(conditional/at [implicit nested-cmd*])

#f))]

[(conditional/colon-frame? x)

(let ([altern (conditional/colon-frame-altern x)])

(unless altern

($oops who "no ~~; found within ~a...~~]" (frame-directive (car stack))))

(let ([stack (cdr stack)] [cmd* (frame-cmd* x)])

(directive

(conditional/colon [implicit altern]

[implicit nested-cmd*])

#f)))]

[(conditional-frame? x)

(let ([stack (cdr stack)] [cmd* (frame-cmd* x)])

(let ([n (conditional-frame-n x)])

(if (conditional-frame-default? x)

(directive

(conditional [implicit n]

[implicit (list->vector (reverse (conditional-frame-cases x)))]

[implicit nested-cmd*])

#f)

(directive

(conditional [implicit n]

[implicit (list->vector (reverse (cons nested-cmd* (conditional-frame-cases x))))]

[implicit '()])

#f))))]

[else (misplaced-directive)])))]

[(#\<)

(parameters ([mincol (nnfixnum? mincol 0)]

[colinc (nnfixnum? colinc 1)]

[minpad (nnfixnum? minpad 0)]

[pc (char? pad-char #\space)])

(state s0

([stack (cons (make-justify-frame (substring cntl b (fx+ i 1)) cmd* mincol colinc minpad pc colon? at?) stack)]

[cmd* '()])

(fx+ i 1)))]

[(#\>)

(no-at)

(let ([x (and (not (null? stack)) (car stack))])

(unless (justify-frame? x) (misplaced-directive))

(let ([nested-cmd* (reverse cmd*)])

(let ([stack (cdr stack)] [cmd* (frame-cmd* x)])

(directive

(justify [implicit (justify-frame-mincol x)]

[implicit (justify-frame-colinc x)]

[implicit (justify-frame-minpad x)]

[implicit (justify-frame-pc x)]

[implicit (justify-frame-before? x)]

[implicit (justify-frame-after? x)]

[implicit (justify-frame-initial x)]

[implicit (justify-frame-margin x)]

[implicit (justify-frame-columns x)]

[implicit (reverse (cons nested-cmd* (justify-frame-segments x)))])

0))))]

[(#\~)

(no-at)

(no-colon)

(if (or (null? p*) (equal? p* '(1)))

(state s0 ([cmd* (cons #\~ cmd*)]) (fx+ i 1))

(directive (dup-char [nnfixnum? n 1] [implicit #\~]) 0))]

[(#\|)

(no-at)

(no-colon)

(if (or (null? p*) (equal? p* '(1)))

(state s0 ([cmd* (cons #\page cmd*)]) (fx+ i 1))

(directive (dup-char [nnfixnum? n 1] [implicit #\page]) 0))]

[(#\return) ; ~\r\n is treated like ~\n

(if (eq? (char (fx+ i 1)) #\newline)

(state s6 () (fx+ i 1) b p* colon? at?)

($oops who "unrecognized directive ~~~:c" c))]

[(#\newline)

(parameters ()

(when (and colon? at?)

($oops who

"@ and : modifiers are mutually exclusive for format directive ~~~c"

c))

(cond

[colon? (state s0 () (fx+ i 1))]

[at? (state s0 ([cmd* (cons c cmd*)]) (skip-non-newline-white (fx+ i 1)))]

[else (state s0 () (skip-non-newline-white (fx+ i 1)))]))]

[else ($oops who "unrecognized directive ~~~:c" c)]))))

(state s0 ([nargs 0] [cmd* '()] [stack '()]) 0))))

;;; squash together adjacent strings and characters

(define squash

(lambda (ls)

(define insert-string!

(lambda (s1 i1 s2)

(let ([n2 (string-length s2)])

(do ([i1 i1 (fx+ i1 1)] [i2 0 (fx+ i2 1)])

((fx= i2 n2))

(string-set! s1 i1 (string-ref s2 i2))))))

(define squash0

(lambda (ls)

(let ([a (car ls)] [d (cdr ls)])

(if (null? d)

ls

(if (string? a)

(let-values ([(s d) (squash1 d (string-length a))])

(if (string? s)

(begin (insert-string! s 0 a) (cons s d))

(cons a d)))

(if (char? a)

(let-values ([(s d) (squash1 d 1)])

(if (string? s)

(begin (string-set! s 0 a) (cons s d))

(cons a d)))

(cons a (squash0 d))))))))

(define squash1

(lambda (ls n)

(if (null? ls)

(values n ls)

(let ([a (car ls)] [d (cdr ls)])

(if (string? a)

(let-values ([(s d) (squash1 d (fx+ n (string-length a)))])

(let ([s (if (string? s) s (make-string s))])

(insert-string! s n a)

(values s d)))

(if (char? a)

(let-values ([(s d) (squash1 d (fx+ n 1))])

(let ([s (if (string? s) s (make-string s))])

(string-set! s n a)

(values s d)))

(values n (if (null? d) ls (cons a (squash0 d))))))))))

(if (null? ls) '() (squash0 ls))))

;;; convert simple formats to expressions. returns #f for other inputs.

(define (make-fmt->expr build-quote build-seq build-primcall)

(lambda (src sexpr cmd* op arg*)

(define-syntax make-seq

(syntax-rules ()

[(_ ?a ?d)

(let ([d ?d])

(and d

(let ([a ?a])

(if (null? d) a (build-seq a d)))))]))

(define-syntax make-call

(syntax-rules ()

[(_ src proc arg ...)

(build-primcall src sexpr 'proc (list arg ...))]))

(if (null? cmd*)

(build-quote (void))

(let f ([cmd* cmd*] [arg* arg*] [src src])

(if (null? cmd*)

'()

(let ([cmd (car cmd*)] [cmd* (cdr cmd*)])

(cond

[(string? cmd)

(make-seq (make-call src display-string (build-quote cmd) op)

(f cmd* arg* #f))]

[(char? cmd)

(make-seq (make-call src write-char (build-quote cmd) op)

(f cmd* arg* #f))]

[(fmt? cmd)

(fmt-case cmd

[simple-display ()

(make-seq (make-call src display (car arg*) op)

(f cmd* (cdr arg*) #f))]

[simple-write ()

(make-seq (make-call src write (car arg*) op)

(f cmd* (cdr arg*) #f))]

[cwrite (colon? at?)

(and (not colon?)

(not at?)

(make-seq (make-call src write-char (car arg*) op)

(f cmd* (cdr arg*) #f)))]

[else #f])]

[else ($oops 'fmt->expr "internal error: ~s" cmd)])))))))

;;; perform formatting operation from parsed string (cmd*)

(define dofmt

(lambda (who fmt-op cntl cmd* arg*)

(define flonum->digits #%$flonum->digits)

(define flonum-sign #%$flonum-sign)

(define (exact-integer? x) (or (fixnum? x) (bignum? x)))

(define float-base 10) ; hardcoding base 10 for now

(define fd->string

(lambda (ls d n sign?)

(define flonum-digit->char

(lambda (n)

(string-ref

"#00123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

(fx+ n 2))))

(let ([s (car ls)] [e (cadr ls)] [ls (cddr ls)])

(let ([op (open-output-string)])

(if (eqv? s -1)

(write-char #\- op)

(when sign? (write-char #\+ op)))

(cond

[(fx< e 0)

(when (fx> n 0) (display (make-string n #\0) op))

(write-char #\. op)

(if (and (not d) (fx= (car ls) -1)) ; some flavor of 0.0

(write-char #\0 op)

(do ([e e (fx+ e 1)] [d d (and d (fx- d 1))])

((or (fx>= e -1) (and d (fx= d 0)))

(do ([ls ls (cdr ls)] [d d (and d (fx- d 1))])

((if d (fx= d 0) (fx< (car ls) 0)))

(write-char (flonum-digit->char (car ls)) op)))

(write-char #\0 op)))]

[(fx= (car ls) -1) ; some flavor of 0.0

(display (make-string (if (and (fx= n 0) (eqv? d 0)) 1 n) #\0) op)

(write-char #\. op)

(display (make-string (or d 1) #\0) op)]

[else

(let ([n (fx- n e 1)])

(when (fx> n 0) (display (make-string n #\0) op)))

(write-char (flonum-digit->char (car ls)) op)

(do ([ls (cdr ls) (cdr ls)] [e e (fx- e 1)])

((fx= e 0)

(write-char #\. op)

(if (and (not d) (fx< (car ls) 0))

(write-char (flonum-digit->char (car ls)) op)

(do ([ls ls (cdr ls)] [d d (and d (fx- d 1))])

((if d (fx= d 0) (fx< (car ls) 0)))

(write-char (flonum-digit->char (car ls)) op))))

(write-char (flonum-digit->char (car ls)) op))])

(get-output-string op)))))

(define string-upcase!

(lambda (s)

(let ([n (string-length s)])

(do ([i 0 (fx+ i 1)])

((fx= i n))

(string-set! s i (char-upcase (string-ref s i)))))))

(define string-downcase!

(lambda (s)

(let ([n (string-length s)])

(do ([i 0 (fx+ i 1)])

((fx= i n))

(string-set! s i (char-downcase (string-ref s i)))))))

(define string-capitalize!

(lambda (s)

(let ([n (string-length s)])

(define interword

(lambda (i)

(unless (fx= i n)

(let ([c (string-ref s i)])

(if (or (char-alphabetic? c) (char-numeric? c))

(begin

(string-set! s i (char-upcase c))

(intraword (fx+ i 1)))

(interword (fx+ i 1)))))))

(define intraword

(lambda (i)

(unless (fx= i n)

(let ([c (string-ref s i)])

(if (or (char-alphabetic? c) (char-numeric? c))

(begin

(string-set! s i (char-downcase c))

(intraword (fx+ i 1)))

(interword (fx+ i 1)))))))

(interword 0))))

(define string-capitalize-first!

(lambda (s)

(let ([n (string-length s)])

(unless (fx= (string-length s) 0)

(string-set! s 0 (char-upcase (string-ref s 0)))

(do ([i 1 (fx+ i 1)])

((fx= i n))

(string-set! s i (char-downcase (string-ref s i))))))))

(define-syntax pad

(syntax-rules ()

[(_ mincol colinc minpad pad-char left? op expr)

(if (and (fx= mincol 0) (fx= minpad 0))

expr

(let ([s (let ([op (open-output-string)])

expr

(get-output-string op))])

(unless left? (display s op))

(let ([n (let ([n (fxmax 0 (fx- mincol minpad (string-length s)))])

(fx+ minpad

(fx* (fxquotient

(fx+ n (fx- colinc 1))

colinc)

colinc)))])

(unless (fx= n 0)

(display (make-string n pad-char) op)))

(when left? (display s op))))]))

(define (padnum w oc pc op s)

(if (not w)

(display s op)

(let ([n (string-length s)])

(cond

[(fx> n w)

(if oc

(display (make-string w oc) op)

(display s op))]

[else

(when (fx< n w) (display (make-string (fx- w n) pc) op))

(display s op)]))))

(define (write-old-roman x op)

(if (<= 1 x 4999)

(let f ([x x] [a '(1000 . #\M)] [ls '((500 . #\D) (100 . #\C) (50 . #\L) (10 . #\X) (5 . #\V) (1 . #\I))])

(if (>= x (car a))

(begin (write-char (cdr a) op) (f (- x (car a)) a ls))

(unless (null? ls) (f x (car ls) (cdr ls)))))

(fprintf op "~d" x)))

(define (write-roman x op)

(if (<= 1 x 3999)

(let f ([x x] [a '(1000 . "M")] [ls '((900 . "CM") (500 . "D") (400 . "CD") (100 . "C") (90 . "XC") (50 . "L") (40 . "XL") (10 . "X") (9 . "IX") (5 . "V") (4 . "IV") (1 . "I"))])

(if (>= x (car a))

(begin (display (cdr a) op) (f (- x (car a)) a ls))

(unless (null? ls) (f x (car ls) (cdr ls)))))

(fprintf op "~d" x)))

(module (write-ordinal write-cardinal)

(define (f100 x op)

(cond

[(>= x 100)

(f10 (quotient x 100) op)

(display " hundred" op)

(let ([x (remainder x 100)])

(unless (= x 0)

(display " " op)

(f10 x op)))]

[else (f10 x op)]))

(define (f10 x op)

(cond

[(>= x 20)

(display (vector-ref v20 (quotient x 10)) op)

(let ([x (remainder x 10)])

(unless (= x 0)

(display "-" op)

(f10 x op)))]

[else (display (vector-ref v0 x) op)]))

(define (f1000000 x op)

(cond

[(>= x 1000000)

(f100 (quotient x 1000000) op)

(display " million" op)

(let ([x (remainder x 1000000)])

(unless (= x 0)

(display " " op)

(f1000 x op)))]

[else (f1000 x op)]))

(define (f1000 x op)

(cond

[(<= 1100 x 1999) (f100 x op)]

[(>= x 1000)

(f100 (quotient x 1000) op)

(display " thousand" op)

(let ([x (remainder x 1000)])

(unless (= x 0)

(display " " op)

(f100 x op)))]

[else (f100 x op)]))

(define (*f1000000 x op)

(cond

[(>= x 1000000)

(f100 (quotient x 1000000) op)

(let ([x (remainder x 1000000)])

(if (= x 0)

(display " millionth" op)

(begin

(display " million " op)

(*f1000 x op))))]

[else (*f1000 x op)]))

(define (*f1000 x op)

(cond

[(<= 1100 x 1999) (*f100 x op)]

[(>= x 1000)

(f100 (quotient x 1000) op)

(let ([x (remainder x 1000)])

(if (= x 0)

(display " thousandth" op)

(begin

(display " thousand " op)

(*f100 x op))))]

[else (*f100 x op)]))

(define (*f100 x op)

(cond

[(>= x 100)

(f10 (quotient x 100) op)

(let ([x (remainder x 100)])

(if (= x 0)

(display " hundredth" op)

(begin

(display " hundred " op)

(*f10 x op))))]

[else (*f10 x op)]))

(define (*f10 x op)