1;;; format.ss 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16#| TODO: 17 * more tests 18 - tests of format with #f, #t, or port as first argument; test of printf 19 and fprintf, tests that exercise all paths of cp1in format handler 20 - verify complete coverage of code paths 21 - extract all tests from cltl2 22 - more # and v parameter tests 23 - ~^ tests: 24 - need tests for outside abort, abort in indirect, nested {super-,}abort 25 in conditionals, nested {super-,}abort in case-conversion, etc. 26 - need tests with one parameter and two parameters 27 - ~* and ~:p tests for moving around loop args 28 - test float printing with Bob's set of floats 29 * use something better than string-append for constructing ~f and ~e output 30 * use more efficient dispatch, e.g., have case use binary search for fixnum 31 keys; or modify compiler to use jump tables for well-behaved case's 32 * look into not hardcoding float-base = 10 33 * vparams adds substantial allocation overhead, probably because of the 34 compiler's handling of mvlet producers containing if expressions; fix 35 the compiler 36 * abstract out Chez Scheme specifics, like display-string, $list-length, 37 string ports, use of generic port 38|# 39 40;;; missing directives 41;;; pretty-printer controls (^_, ~:>, ~i, ~:t ~/name/) 42 43;;; known incompatibilities with Common Lisp 44;;; : [print nil as ()] modifier ignored for ~a 45;;; : [print nil as ()] modifier treated as "print-gensym #f" for ~s 46;;; common lisp doesn't complain when there are unused arguments, 47;;; may not complain when there are too few arguments. we always 48;;; complain when there are too few and complain when we can determine 49;;; statically that there are too many 50;;; we insist on real argument for ~f, ~e, and ~g; common lisp is 51;;; lax and sends off anything else to ~D. 52 53;;; other notees 54;;; we always assume that format starts at the beginning of a line 55;;; in support of ~&, ~t, and ~<...> 56 57(let () 58 ;;; configuration 59 60 ;; check for too many args at parse time 61 (define static-too-many-args-check #t) 62 ;; check for too many args at parse time for indirects and loop bodies 63 (define indirect-too-many-args-check #f) 64 ;; check for too many args at run time. the check is always suppressed 65 ;; when we terminate a format or indirect format as the result of ~^ 66 (define dynamic-too-many-args-check #f) 67 68 ;;; predicates used to check format parameters 69 (define nnfixnum? (lambda (x) (and (fixnum? x) (fx>= x 0)))) 70 (define true? (lambda (x) #t)) 71 (define pfixnum? (lambda (x) (and (fixnum? x) (fx> x 0)))) 72 (define radix? (lambda (x) (and (fixnum? x) (fx<= 2 x 36)))) 73 74 ; we require nongenerative records because the compiler embeds parsed 75 ; format strings in object files. force cp1in-parse-format to return #f 76 ; to bootstrap after making changes to any of these records 77 (define-datatype (#{fmt cgos0c9ufi1rq-fd} (immutable directive)) 78 (#{newline cgos0c9ufi1rq-ez} n) 79 (#{fresh-line cgos0c9ufi1rq-fc} n) 80 (#{dup-char cgos0c9ufi1rq-fh} n c) 81 (#{display cgos0c9ufi1rq-fi} mincol colinc minpad pad-char left?) 82 (#{simple-display cgos0c9ufi1rq-et}) 83 (#{simple-write cgos0c9ufi1rq-es}) 84 (#{write cgos0c9ufi1rq-ei} mincol colinc minpad pad-char nogensym? left?) 85 (#{cwrite cgos0c9ufi1rq-fk} colon? at?) 86 (#{fwrite cgos0c9ufi1rq-fb} w d k oc pc sign?) 87 (#{ewrite cgos0c9ufi1rq-ff} w d ew k oc pc ec sign?) 88 (#{gwrite cgos0c9ufi1rq-e9} w d ew k oc pc ec sign?) 89 (#{$write cgos0c9ufi1rq-eg} d n w pc sign-before-pad? sign?) 90 (#{write-radix cgos0c9ufi1rq-eh} base w pc cc ci sign? commas?) 91 (#{plural cgos0c9ufi1rq-ey} back-up? y/ies?) 92 (#{fancy-radix cgos0c9ufi1rq-fe} colon? at?) 93 (#{indirect cgos0c9ufi1rq-e6} splice?) 94 (#{goto cgos0c9ufi1rq-fa} n reverse? absolute?) 95 (#{tabulate cgos0c9ufi1rq-ek} colnum colinc relative?) 96 (#{convert-case cgos0c9ufi1rq-fl} nested-cmd* colon? at?) 97 (#{conditional cgos0c9ufi1rq-fo} n cases default) 98 (#{conditional/at cgos0c9ufi1rq-fn} consequent) 99 (#{conditional/colon cgos0c9ufi1rq-fm} alternative consequent) 100 (#{justify cgos0c9ufi1rq-e1} mincol colinc minpad pad-char before? after? initial margin columns segments) 101 (#{abort cgos0c9ufi1rq-ft} n m super?) 102 (#{iteration cgos0c9ufi1rq-e2} body n sublists? use-remaining? at-least-once?) 103 (#{columntrack cgos0c9ufi1rq-fq} body) 104 ) 105 106 ;;; parse string to list of strings, chars, and fmt records 107 (define parse 108 (lambda (who cntl) 109 (define column? #f) 110 (define-syntactic-monad state nargs cmd* stack) 111 (define-record-type frame 112 (fields (immutable directive) (immutable cmd*)) 113 (nongenerative)) 114 (define-record-type cvtcase-frame 115 (parent frame) 116 (fields (immutable colon?) (immutable at?)) 117 (nongenerative) 118 (sealed #t)) 119 (define-record-type conditional/at-frame 120 (parent frame) 121 (nongenerative) 122 (sealed #t)) 123 (define-record-type conditional/colon-frame 124 (parent frame) 125 (fields (mutable altern)) 126 (nongenerative) 127 (sealed #t) 128 (protocol 129 (lambda (make-new) 130 (lambda (directive cmd*) 131 ((make-new directive cmd*) #f))))) 132 (define-record-type conditional-frame 133 (parent frame) 134 (fields (immutable n) (mutable cases) (mutable default?)) 135 (nongenerative) 136 (sealed #t) 137 (protocol 138 (lambda (make-new) 139 (lambda (directive cmd* n) 140 ((make-new directive cmd*) n '() #f))))) 141 (define-record-type justify-frame 142 (parent frame) 143 (fields 144 (immutable mincol) 145 (immutable colinc) 146 (immutable minpad) 147 (immutable pc) 148 (immutable before?) 149 (immutable after?) 150 (mutable segments) 151 (mutable initial) 152 (mutable margin) 153 (mutable columns)) 154 (nongenerative) 155 (sealed #t) 156 (protocol 157 (lambda (make-new) 158 (lambda (directive cmd* mincol colinc minpad pc before? after?) 159 ((make-new directive cmd*) mincol colinc minpad pc before? after? '() #f #f #f))))) 160 (define-record-type iteration-frame 161 (parent frame) 162 (fields (immutable n) (immutable sublists?) (immutable use-remaining?)) 163 (nongenerative) 164 (sealed #t)) 165 (define incomplete-format-directive 166 (lambda (b i) 167 ($oops who "incomplete format directive ~s" 168 (substring cntl b i)))) 169 (define (bump x n) (and x n (fx+ x n))) 170 (unless (string? cntl) 171 ($oops who "~s is not a string" cntl)) 172 (let ([nmax (fx- (string-length cntl) 1)]) 173 (define char 174 (lambda (i) 175 (if (fx> i nmax) 176 #!eof 177 (string-ref cntl i)))) 178 (define sfinal 179 (state lambda () 180 (unless (null? stack) 181 ($oops who "unclosed directive ~a" (frame-directive (car stack)))) 182 (let ([cmd* (reverse cmd*)]) 183 (values (if column? (list (fmt-columntrack "" cmd*)) cmd*) nargs)))) 184 (define s0 185 (state lambda (i) 186 (let ([c (char i)]) 187 (state-case c 188 [eof (state sfinal ())] 189 [(#\~) (state s3 () (fx+ i 1) i)] 190 [else (state s1 () (fx+ i 1) i c)])))) 191 (define s1 192 (state lambda (i b c0) 193 (let ([c (char i)]) 194 (state-case c 195 [eof (state sfinal ([cmd* (cons c0 cmd*)]))] 196 [(#\~) (state s3 ([cmd* (cons c0 cmd*)]) (fx+ i 1) i)] 197 [else (state s2 () (fx+ i 1) b)])))) 198 (define s2 199 (state lambda (i b) 200 (let ([c (char i)]) 201 (state-case c 202 [eof (state sfinal ([cmd* (cons (substring cntl b i) cmd*)]))] 203 [(#\~) (state s3 ([cmd* (cons (substring cntl b i) cmd*)]) (fx+ i 1) i)] 204 [else (state s2 () (fx+ i 1) b)])))) 205 (define s3 206 (state lambda (i b) 207 (let ([c (char i)]) 208 (state-case c 209 [eof (incomplete-format-directive b i)] 210 [(#\~) (state s1 () (fx+ i 1) i #\~)] 211 [(#\- #\+) (state s4-sign () (fx+ i 1) b '() i)] 212 [((#\0 - #\9)) (state s4-digit () (fx+ i 1) b '() i)] 213 [(#\,) (state s4-comma () (fx+ i 1) b '(#f))] 214 [(#\') (state s4-quote () (fx+ i 1) b '())] 215 [(#\#) (state s4-after-param () (fx+ i 1) b '(hash))] 216 [(#\v) (state s4-after-param ([nargs (bump nargs 1)]) (fx+ i 1) b '(v))] 217 [else (state s5 () i b '())])))) 218 (define s4-sign 219 (state lambda (i b p* bp) 220 (let ([c (char i)]) 221 (state-case c 222 [eof (incomplete-format-directive b i)] 223 [((#\0 - #\9)) (state s4-digit () (fx+ i 1) b p* bp)] 224 [else (incomplete-format-directive b i)])))) 225 (define s4-quote 226 (state lambda (i b p*) 227 (let ([c (char i)]) 228 (state-case c 229 [eof (incomplete-format-directive b i)] 230 [else (state s4-after-param () (fx+ i 1) b (cons c p*))])))) 231 (define s4-after-param 232 (state lambda (i b p*) 233 (let ([c (char i)]) 234 (state-case c 235 [eof (incomplete-format-directive b i)] 236 [(#\,) (state s4-comma () (fx+ i 1) b p*)] 237 [else (state s5 () i b (reverse p*))])))) 238 (define s4-digit 239 (state lambda (i b p* bp) 240 (let ([c (char i)]) 241 (state-case c 242 [eof (incomplete-format-directive b i)] 243 [((#\0 - #\9)) (state s4-digit () (fx+ i 1) b p* bp)] 244 [(#\,) (state s4-comma () (fx+ i 1) b (cons (string->number (substring cntl bp i)) p*))] 245 [else (state s5 () i b (reverse (cons (string->number (substring cntl bp i)) p*)))])))) 246 (define s4-comma 247 (state lambda (i b p*) 248 (let ([c (char i)]) 249 (state-case c 250 [eof (incomplete-format-directive b i)] 251 [(#\- #\+) (state s4-sign () (fx+ i 1) b p* i)] 252 [((#\0 - #\9)) (state s4-digit () (fx+ i 1) b p* i)] 253 [(#\,) (state s4-comma () (fx+ i 1) b (cons #f p*))] 254 [(#\') (state s4-quote () (fx+ i 1) b p*)] 255 [(#\#) (state s4-after-param () (fx+ i 1) b (cons 'hash p*))] 256 [(#\v) (state s4-after-param ([nargs (bump nargs 1)]) (fx+ i 1) b (cons 'v p*))] 257 [else (state s5 () i b (reverse (cons #f p*)))])))) 258 (define s5 259 (state lambda (i b p*) 260 (let ([c (char i)]) 261 (state-case c 262 [eof (incomplete-format-directive b i)] 263 [(#\:) (state s5-colon () (fx+ i 1) b p*)] 264 [(#\@) (state s5-at () (fx+ i 1) b p*)] 265 [else (state s6 () i b p* #f #f)])))) 266 (define s5-colon 267 (state lambda (i b p*) 268 (let ([c (char i)]) 269 (state-case c 270 [eof (incomplete-format-directive b i)] 271 [(#\@) (state s6 () (fx+ i 1) b p* #t #t)] 272 [else (state s6 () i b p* #t #f)])))) 273 (define s5-at 274 (state lambda (i b p*) 275 (let ([c (char i)]) 276 (state-case c 277 [eof (incomplete-format-directive b i)] 278 [(#\:) (state s6 () (fx+ i 1) b p* #t #t)] 279 [else (state s6 () i b p* #f #t)])))) 280 (define s6 281 (state lambda (i b p* colon? at?) 282 (define skip-non-newline-white 283 (lambda (i) 284 (let ([c (char i)]) 285 (state-case c 286 [eof i] 287 [(#\space #\tab #\page #\return) 288 (skip-non-newline-white (fx+ i 1))] 289 [else i])))) 290 (let ([c (char i)]) 291 (define no-colon 292 (lambda () 293 (when colon? 294 ($oops who "~~~c directive has no : flag" c)))) 295 (define no-at 296 (lambda () 297 (when at? 298 ($oops who "~~~c directive has no @ flag" c)))) 299 (define too-many-parameters 300 (lambda () 301 ($oops who 302 "too many parameters in ~~~c directive ~s" 303 c (substring cntl b (fx+ i 1))))) 304 (define missing-parameter 305 (lambda (what) 306 ($oops who 307 "missing required ~s parameter in ~~~c directive ~s" 308 what c (substring cntl b (fx+ i 1))))) 309 (define invalid-parameter 310 (lambda (what arg) 311 ($oops who 312 "invalid ~s parameter ~a in ~~~c directive ~s" 313 what arg c (substring cntl b (fx+ i 1))))) 314 (define misplaced-directive 315 (lambda () 316 ($oops who "misplaced directive ~s" 317 (substring cntl b (fx+ i 1))))) 318 (define-syntax parameters 319 (lambda (x) 320 (define process-param 321 (lambda (t* param* body) 322 (if (null? param*) 323 body 324 (with-syntax ([body (process-param (cdr t*) (cdr param*) body)] 325 [t (car t*)]) 326 (syntax-case (car param*) (implicit) 327 [(implicit e) #'(let ([t e]) body)] 328 [(type? p) 329 #'(begin 330 (when (null? p*) (missing-parameter 'p)) 331 (let ([t (car p*)] [p* (cdr p*)]) 332 (when (not t) (missing-parameter 'p)) 333 (unless (or (type? t) (memq t '(hash v))) (invalid-parameter 'p t)) 334 body))] 335 [(type? p default) 336 #'(let ([proc (lambda (t p*) body)]) 337 (if (null? p*) 338 (proc 'default p*) 339 (let ([t (car p*)] [p* (cdr p*)]) 340 (if (not t) 341 (proc default p*) 342 (begin 343 (unless (or (type? t) (memq t '(hash v))) (invalid-parameter 'p t)) 344 (proc t p*))))))]))))) 345 (syntax-case x () 346 [(_ ([t param] ...) e1 e2 ...) 347 (process-param 348 #'(t ...) 349 #'(param ...) 350 #'(begin 351 (unless (null? p*) (too-many-parameters)) 352 (let () e1 e2 ...)))]))) 353 (define-syntax directive 354 (lambda (x) 355 (define construct-name 356 (lambda (template-identifier . args) 357 (datum->syntax 358 template-identifier 359 (string->symbol 360 (apply string-append 361 (map (lambda (x) 362 (if (string? x) 363 x 364 (symbol->string (syntax->datum x)))) 365 args)))))) 366 (syntax-case x () 367 [(k (d param ...) n) 368 (with-syntax ([(t ...) (generate-temporaries #'(param ...))] 369 [fmt-d (construct-name #'d "fmt-" #'d)]) 370 (with-implicit (k state cmd* nargs) 371 #'(parameters ([t param] ...) 372 (state s0 373 ([cmd* (cons (fmt-d (substring cntl b (fx+ i 1)) t ...) cmd*)] 374 [nargs (bump nargs n)]) 375 (fx+ i 1)))))]))) 376 (define-syntax parse-radix 377 (syntax-rules () 378 [(_ base) 379 (directive 380 (write-radix [implicit base] 381 [nnfixnum? w #f] 382 [char? pad-char #\space] 383 [char? comma-char #\,] 384 [pfixnum? comma-interval 3] 385 [implicit at?] 386 [implicit colon?]) 387 1)])) 388 (state-case c 389 [eof (incomplete-format-directive b i)] 390 [(#\% #\n #\N) 391 (no-at) 392 (no-colon) 393 (if (or (null? p*) (equal? p* '(1))) 394 (state s0 ([cmd* (cons #\newline cmd*)]) (fx+ i 1)) 395 (directive (dup-char [nnfixnum? n 1] [implicit #\newline]) 0))] 396 [(#\&) 397 (no-at) 398 (no-colon) 399 (directive (fresh-line [nnfixnum? n 1]) 0)] 400 [(#\a #\A) 401 (no-colon) 402 (if (null? p*) 403 (directive 404 (simple-display) 405 1) 406 (directive 407 (display [nnfixnum? mincol 0] 408 [pfixnum? colinc 1] 409 [nnfixnum? minpad 0] 410 [char? pad-char #\space] 411 [implicit at?]) 412 1))] 413 [(#\s #\S #\w #\W) 414 (if (and (null? p*) (not colon?)) 415 (directive 416 (simple-write) 417 1) 418 (directive 419 (write [nnfixnum? mincol 0] 420 [pfixnum? colinc 1] 421 [nnfixnum? minpad 0] 422 [char? pad-char #\space] 423 [implicit colon?] 424 [implicit at?]) 425 1))] 426 [(#\f #\F) 427 (no-colon) 428 (directive 429 (fwrite [nnfixnum? w #f] 430 [nnfixnum? d #f] 431 [fixnum? k 0] 432 [char? overflow-char #f] 433 [char? pad-char #\space] 434 [implicit at?]) 435 1)] 436 [(#\e #\E) 437 (no-colon) 438 (directive 439 (ewrite [nnfixnum? w #f] 440 [nnfixnum? d #f] 441 [pfixnum? e #f] 442 [fixnum? k 1] 443 [char? overflow-char #f] 444 [char? pad-char #\space] 445 [char? exponent-char #\e] 446 [implicit at?]) 447 1)] 448 [(#\g #\G) 449 (no-colon) 450 (directive 451 (gwrite [nnfixnum? w #f] 452 [nnfixnum? d #f] 453 [pfixnum? e #f] 454 [fixnum? k 1] ; assumption 455 [char? overflow-char #f] 456 [char? pad-char #\space] 457 [char? exponent-char #\e] 458 [implicit at?]) 459 1)] 460 [(#\$) 461 (directive 462 ($write [nnfixnum? d 2] 463 [nnfixnum? n 1] 464 [nnfixnum? w 0] 465 [char? pad-char #\space] 466 [implicit colon?] 467 [implicit at?]) 468 1)] 469 [(#\c #\C) 470 (directive 471 (cwrite [implicit colon?] [implicit at?]) 472 1)] 473 [(#\b #\B) (parse-radix 2)] 474 [(#\o #\O) (parse-radix 8)] 475 [(#\d #\D) (parse-radix 10)] 476 [(#\x #\X) (parse-radix 16)] 477 [(#\r #\R) 478 (if (null? p*) 479 (directive 480 (fancy-radix [implicit colon?] [implicit at?]) 481 1) 482 (directive 483 (write-radix [radix? n 10] 484 [nnfixnum? w #f] 485 [char? pad-char #\space] 486 [char? comma-char #\,] 487 [pfixnum? comma-interval 3] 488 [implicit at?] 489 [implicit colon?]) 490 1))] 491 [(#\p #\P) 492 (directive 493 (plural [implicit colon?] [implicit at?]) 494 (if colon? 0 1))] 495 [(#\t #\T) 496 (no-colon) 497 (set! column? #t) 498 (directive 499 (tabulate [nnfixnum? colnum 1] 500 [nnfixnum? colinc 1] 501 [implicit at?]) 502 0)] 503 [(#\?) 504 (no-colon) 505 (set! column? #t) 506 (directive 507 (indirect [implicit at?]) 508 (if at? #f 2))] 509 [(#\*) 510 (when (and colon? at?) 511 ($oops who 512 "@ and : modifiers are mutually exclusive for format directive ~~~c" 513 c)) 514 (directive 515 (goto [nnfixnum? n #f] [implicit colon?] [implicit at?]) 516 #f)] 517 [(#\( #|)|#) 518 (parameters () 519 (state s0 520 ([stack (cons (make-cvtcase-frame (substring cntl b (fx+ i 1)) cmd* colon? at?) stack)] 521 [cmd* '()]) 522 (fx+ i 1)))] 523 [(#|(|# #\)) 524 (no-at) 525 (no-colon) 526 (let ([x (and (not (null? stack)) (car stack))]) 527 (unless (cvtcase-frame? x) (misplaced-directive)) 528 (let ([nested-cmd* (reverse cmd*)]) 529 (let ([stack (cdr stack)] [cmd* (frame-cmd* x)]) 530 (directive 531 (convert-case [implicit nested-cmd*] 532 [implicit (cvtcase-frame-colon? x)] 533 [implicit (cvtcase-frame-at? x)]) 534 0))))] 535 [(#\;) 536 (no-at) 537 (let ([x (and (not (null? stack)) (car stack))]) 538 (cond 539 [(and (conditional/colon-frame? x) 540 (not colon?) 541 (not (conditional/colon-frame-altern x))) 542 (parameters () 543 (conditional/colon-frame-altern-set! x (reverse cmd*))) 544 (state s0 ([cmd* '()]) (fx+ i 1))] 545 [(and (conditional-frame? x) (not (conditional-frame-default? x))) 546 (parameters () 547 (when colon? (conditional-frame-default?-set! x #t)) 548 (conditional-frame-cases-set! x 549 (cons (reverse cmd*) (conditional-frame-cases x)))) 550 (state s0 ([cmd* '()]) (fx+ i 1))] 551 [(and (justify-frame? x) 552 (or (not colon?) 553 (and (not (justify-frame-initial x)) 554 (null? (justify-frame-segments x))))) 555 (if colon? 556 (parameters ([margin (nnfixnum? n 0)] 557 [cols (nnfixnum? lw 72)]) 558 (set! column? #t) 559 (justify-frame-initial-set! x (reverse cmd*)) 560 (justify-frame-margin-set! x margin) 561 (justify-frame-columns-set! x cols)) 562 (parameters () 563 (justify-frame-segments-set! x 564 (cons (reverse cmd*) (justify-frame-segments x))))) 565 (state s0 ([cmd* '()]) (fx+ i 1))] 566 [else (misplaced-directive)]))] 567 [(#\^) 568 (no-at) 569 (directive 570 (abort [true? n #f] [true? m #f] [implicit colon?]) 571 #f)] 572 [(#\{ #|}|#) 573 (when (null? cmd*) (set! column? #t)) 574 (parameters ([n (nnfixnum? n #f)]) 575 (state s0 576 ([stack (cons (make-iteration-frame (substring cntl b (fx+ i 1)) cmd* n colon? at?) stack)] 577 [cmd* '()]) 578 (fx+ i 1)))] 579 [(#|{|# #\}) 580 (no-at) 581 (let ([x (and (not (null? stack)) (car stack))]) 582 (unless (iteration-frame? x) (misplaced-directive)) 583 (let ([nested-cmd* (reverse cmd*)]) 584 (let ([stack (cdr stack)] [cmd* (frame-cmd* x)]) 585 (directive 586 (iteration [implicit nested-cmd*] 587 [implicit (iteration-frame-n x)] 588 [implicit (iteration-frame-sublists? x)] 589 [implicit (iteration-frame-use-remaining? x)] 590 [implicit colon?]) 591 #f))))] 592 [(#\[ #|]|#) 593 (if at? 594 (if colon? 595 ($oops who "@ and : modifiers are mutually exclusive for format directive ~~~c" c) 596 (parameters () 597 (state s0 598 ([stack (cons (make-conditional/at-frame (substring cntl b (fx+ i 1)) cmd*) stack)] 599 [cmd* '()]) 600 (fx+ i 1)))) 601 (if colon? 602 (parameters () 603 (state s0 604 ([stack (cons (make-conditional/colon-frame (substring cntl b (fx+ i 1)) cmd*) stack)] 605 [cmd* '()]) 606 (fx+ i 1))) 607 (parameters ([n (nnfixnum? n #f)]) 608 (state s0 609 ([stack (cons (make-conditional-frame (substring cntl b (fx+ i 1)) cmd* n) stack)] 610 [cmd* '()]) 611 (fx+ i 1)))))] 612 [(#|[|# #\]) 613 (no-at) 614 (no-colon) 615 (let ([x (and (not (null? stack)) (car stack))]) 616 (let ([nested-cmd* (reverse cmd*)]) 617 (cond 618 [(conditional/at-frame? x) 619 (let ([stack (cdr stack)] [cmd* (frame-cmd* x)]) 620 (directive 621 (conditional/at [implicit nested-cmd*]) 622 #f))] 623 [(conditional/colon-frame? x) 624 (let ([altern (conditional/colon-frame-altern x)]) 625 (unless altern 626 ($oops who "no ~~; found within ~a...~~]" (frame-directive (car stack)))) 627 (let ([stack (cdr stack)] [cmd* (frame-cmd* x)]) 628 (directive 629 (conditional/colon [implicit altern] 630 [implicit nested-cmd*]) 631 #f)))] 632 [(conditional-frame? x) 633 (let ([stack (cdr stack)] [cmd* (frame-cmd* x)]) 634 (let ([n (conditional-frame-n x)]) 635 (if (conditional-frame-default? x) 636 (directive 637 (conditional [implicit n] 638 [implicit (list->vector (reverse (conditional-frame-cases x)))] 639 [implicit nested-cmd*]) 640 #f) 641 (directive 642 (conditional [implicit n] 643 [implicit (list->vector (reverse (cons nested-cmd* (conditional-frame-cases x))))] 644 [implicit '()]) 645 #f))))] 646 [else (misplaced-directive)])))] 647 [(#\<) 648 (parameters ([mincol (nnfixnum? mincol 0)] 649 [colinc (nnfixnum? colinc 1)] 650 [minpad (nnfixnum? minpad 0)] 651 [pc (char? pad-char #\space)]) 652 (state s0 653 ([stack (cons (make-justify-frame (substring cntl b (fx+ i 1)) cmd* mincol colinc minpad pc colon? at?) stack)] 654 [cmd* '()]) 655 (fx+ i 1)))] 656 [(#\>) 657 (no-at) 658 (let ([x (and (not (null? stack)) (car stack))]) 659 (unless (justify-frame? x) (misplaced-directive)) 660 (let ([nested-cmd* (reverse cmd*)]) 661 (let ([stack (cdr stack)] [cmd* (frame-cmd* x)]) 662 (directive 663 (justify [implicit (justify-frame-mincol x)] 664 [implicit (justify-frame-colinc x)] 665 [implicit (justify-frame-minpad x)] 666 [implicit (justify-frame-pc x)] 667 [implicit (justify-frame-before? x)] 668 [implicit (justify-frame-after? x)] 669 [implicit (justify-frame-initial x)] 670 [implicit (justify-frame-margin x)] 671 [implicit (justify-frame-columns x)] 672 [implicit (reverse (cons nested-cmd* (justify-frame-segments x)))]) 673 0))))] 674 [(#\~) 675 (no-at) 676 (no-colon) 677 (if (or (null? p*) (equal? p* '(1))) 678 (state s0 ([cmd* (cons #\~ cmd*)]) (fx+ i 1)) 679 (directive (dup-char [nnfixnum? n 1] [implicit #\~]) 0))] 680 [(#\|) 681 (no-at) 682 (no-colon) 683 (if (or (null? p*) (equal? p* '(1))) 684 (state s0 ([cmd* (cons #\page cmd*)]) (fx+ i 1)) 685 (directive (dup-char [nnfixnum? n 1] [implicit #\page]) 0))] 686 [(#\return) ; ~\r\n is treated like ~\n 687 (if (eq? (char (fx+ i 1)) #\newline) 688 (state s6 () (fx+ i 1) b p* colon? at?) 689 ($oops who "unrecognized directive ~~~:c" c))] 690 [(#\newline) 691 (parameters () 692 (when (and colon? at?) 693 ($oops who 694 "@ and : modifiers are mutually exclusive for format directive ~~~c" 695 c)) 696 (cond 697 [colon? (state s0 () (fx+ i 1))] 698 [at? (state s0 ([cmd* (cons c cmd*)]) (skip-non-newline-white (fx+ i 1)))] 699 [else (state s0 () (skip-non-newline-white (fx+ i 1)))]))] 700 [else ($oops who "unrecognized directive ~~~:c" c)])))) 701 (state s0 ([nargs 0] [cmd* '()] [stack '()]) 0)))) 702 703 ;;; squash together adjacent strings and characters 704 (define squash 705 (lambda (ls) 706 (define insert-string! 707 (lambda (s1 i1 s2) 708 (let ([n2 (string-length s2)]) 709 (do ([i1 i1 (fx+ i1 1)] [i2 0 (fx+ i2 1)]) 710 ((fx= i2 n2)) 711 (string-set! s1 i1 (string-ref s2 i2)))))) 712 (define squash0 713 (lambda (ls) 714 (let ([a (car ls)] [d (cdr ls)]) 715 (if (null? d) 716 ls 717 (if (string? a) 718 (let-values ([(s d) (squash1 d (string-length a))]) 719 (if (string? s) 720 (begin (insert-string! s 0 a) (cons s d)) 721 (cons a d))) 722 (if (char? a) 723 (let-values ([(s d) (squash1 d 1)]) 724 (if (string? s) 725 (begin (string-set! s 0 a) (cons s d)) 726 (cons a d))) 727 (cons a (squash0 d)))))))) 728 (define squash1 729 (lambda (ls n) 730 (if (null? ls) 731 (values n ls) 732 (let ([a (car ls)] [d (cdr ls)]) 733 (if (string? a) 734 (let-values ([(s d) (squash1 d (fx+ n (string-length a)))]) 735 (let ([s (if (string? s) s (make-string s))]) 736 (insert-string! s n a) 737 (values s d))) 738 (if (char? a) 739 (let-values ([(s d) (squash1 d (fx+ n 1))]) 740 (let ([s (if (string? s) s (make-string s))]) 741 (string-set! s n a) 742 (values s d))) 743 (values n (if (null? d) ls (cons a (squash0 d)))))))))) 744 (if (null? ls) '() (squash0 ls)))) 745 746 ;;; convert simple formats to expressions. returns #f for other inputs. 747 (define (make-fmt->expr build-quote build-seq build-primcall) 748 (lambda (src sexpr cmd* op arg*) 749 (define-syntax make-seq 750 (syntax-rules () 751 [(_ ?a ?d) 752 (let ([d ?d]) 753 (and d 754 (let ([a ?a]) 755 (if (null? d) a (build-seq a d)))))])) 756 (define-syntax make-call 757 (syntax-rules () 758 [(_ src proc arg ...) 759 (build-primcall src sexpr 'proc (list arg ...))])) 760 (if (null? cmd*) 761 (build-quote (void)) 762 (let f ([cmd* cmd*] [arg* arg*] [src src]) 763 (if (null? cmd*) 764 '() 765 (let ([cmd (car cmd*)] [cmd* (cdr cmd*)]) 766 (cond 767 [(string? cmd) 768 (make-seq (make-call src display-string (build-quote cmd) op) 769 (f cmd* arg* #f))] 770 [(char? cmd) 771 (make-seq (make-call src write-char (build-quote cmd) op) 772 (f cmd* arg* #f))] 773 [(fmt? cmd) 774 (fmt-case cmd 775 [simple-display () 776 (make-seq (make-call src display (car arg*) op) 777 (f cmd* (cdr arg*) #f))] 778 [simple-write () 779 (make-seq (make-call src write (car arg*) op) 780 (f cmd* (cdr arg*) #f))] 781 [cwrite (colon? at?) 782 (and (not colon?) 783 (not at?) 784 (make-seq (make-call src write-char (car arg*) op) 785 (f cmd* (cdr arg*) #f)))] 786 [else #f])] 787 [else ($oops 'fmt->expr "internal error: ~s" cmd)]))))))) 788 789 ;;; perform formatting operation from parsed string (cmd*) 790 (define dofmt 791 (lambda (who fmt-op cntl cmd* arg*) 792 (define flonum->digits #%$flonum->digits) 793 (define flonum-sign #%$flonum-sign) 794 (define (exact-integer? x) (or (fixnum? x) (bignum? x))) 795 (define float-base 10) ; hardcoding base 10 for now 796 (define fd->string 797 (lambda (ls d n sign?) 798 (define flonum-digit->char 799 (lambda (n) 800 (string-ref 801 "#00123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 802 (fx+ n 2)))) 803 (let ([s (car ls)] [e (cadr ls)] [ls (cddr ls)]) 804 (let ([op (open-output-string)]) 805 (if (eqv? s -1) 806 (write-char #\- op) 807 (when sign? (write-char #\+ op))) 808 (cond 809 [(fx< e 0) 810 (when (fx> n 0) (display (make-string n #\0) op)) 811 (write-char #\. op) 812 (if (and (not d) (fx= (car ls) -1)) ; some flavor of 0.0 813 (write-char #\0 op) 814 (do ([e e (fx+ e 1)] [d d (and d (fx- d 1))]) 815 ((or (fx>= e -1) (and d (fx= d 0))) 816 (do ([ls ls (cdr ls)] [d d (and d (fx- d 1))]) 817 ((if d (fx= d 0) (fx< (car ls) 0))) 818 (write-char (flonum-digit->char (car ls)) op))) 819 (write-char #\0 op)))] 820 [(fx= (car ls) -1) ; some flavor of 0.0 821 (display (make-string (if (and (fx= n 0) (eqv? d 0)) 1 n) #\0) op) 822 (write-char #\. op) 823 (display (make-string (or d 1) #\0) op)] 824 [else 825 (let ([n (fx- n e 1)]) 826 (when (fx> n 0) (display (make-string n #\0) op))) 827 (write-char (flonum-digit->char (car ls)) op) 828 (do ([ls (cdr ls) (cdr ls)] [e e (fx- e 1)]) 829 ((fx= e 0) 830 (write-char #\. op) 831 (if (and (not d) (fx< (car ls) 0)) 832 (write-char (flonum-digit->char (car ls)) op) 833 (do ([ls ls (cdr ls)] [d d (and d (fx- d 1))]) 834 ((if d (fx= d 0) (fx< (car ls) 0))) 835 (write-char (flonum-digit->char (car ls)) op)))) 836 (write-char (flonum-digit->char (car ls)) op))]) 837 (get-output-string op))))) 838 (define string-upcase! 839 (lambda (s) 840 (let ([n (string-length s)]) 841 (do ([i 0 (fx+ i 1)]) 842 ((fx= i n)) 843 (string-set! s i (char-upcase (string-ref s i))))))) 844 (define string-downcase! 845 (lambda (s) 846 (let ([n (string-length s)]) 847 (do ([i 0 (fx+ i 1)]) 848 ((fx= i n)) 849 (string-set! s i (char-downcase (string-ref s i))))))) 850 (define string-capitalize! 851 (lambda (s) 852 (let ([n (string-length s)]) 853 (define interword 854 (lambda (i) 855 (unless (fx= i n) 856 (let ([c (string-ref s i)]) 857 (if (or (char-alphabetic? c) (char-numeric? c)) 858 (begin 859 (string-set! s i (char-upcase c)) 860 (intraword (fx+ i 1))) 861 (interword (fx+ i 1))))))) 862 (define intraword 863 (lambda (i) 864 (unless (fx= i n) 865 (let ([c (string-ref s i)]) 866 (if (or (char-alphabetic? c) (char-numeric? c)) 867 (begin 868 (string-set! s i (char-downcase c)) 869 (intraword (fx+ i 1))) 870 (interword (fx+ i 1))))))) 871 (interword 0)))) 872 (define string-capitalize-first! 873 (lambda (s) 874 (let ([n (string-length s)]) 875 (unless (fx= (string-length s) 0) 876 (string-set! s 0 (char-upcase (string-ref s 0))) 877 (do ([i 1 (fx+ i 1)]) 878 ((fx= i n)) 879 (string-set! s i (char-downcase (string-ref s i)))))))) 880 (define-syntax pad 881 (syntax-rules () 882 [(_ mincol colinc minpad pad-char left? op expr) 883 (if (and (fx= mincol 0) (fx= minpad 0)) 884 expr 885 (let ([s (let ([op (open-output-string)]) 886 expr 887 (get-output-string op))]) 888 (unless left? (display s op)) 889 (let ([n (let ([n (fxmax 0 (fx- mincol minpad (string-length s)))]) 890 (fx+ minpad 891 (fx* (fxquotient 892 (fx+ n (fx- colinc 1)) 893 colinc) 894 colinc)))]) 895 (unless (fx= n 0) 896 (display (make-string n pad-char) op))) 897 (when left? (display s op))))])) 898 (define (padnum w oc pc op s) 899 (if (not w) 900 (display s op) 901 (let ([n (string-length s)]) 902 (cond 903 [(fx> n w) 904 (if oc 905 (display (make-string w oc) op) 906 (display s op))] 907 [else 908 (when (fx< n w) (display (make-string (fx- w n) pc) op)) 909 (display s op)])))) 910 (define (write-old-roman x op) 911 (if (<= 1 x 4999) 912 (let f ([x x] [a '(1000 . #\M)] [ls '((500 . #\D) (100 . #\C) (50 . #\L) (10 . #\X) (5 . #\V) (1 . #\I))]) 913 (if (>= x (car a)) 914 (begin (write-char (cdr a) op) (f (- x (car a)) a ls)) 915 (unless (null? ls) (f x (car ls) (cdr ls))))) 916 (fprintf op "~d" x))) 917 (define (write-roman x op) 918 (if (<= 1 x 3999) 919 (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"))]) 920 (if (>= x (car a)) 921 (begin (display (cdr a) op) (f (- x (car a)) a ls)) 922 (unless (null? ls) (f x (car ls) (cdr ls))))) 923 (fprintf op "~d" x))) 924 (module (write-ordinal write-cardinal) 925 (define (f100 x op) 926 (cond 927 [(>= x 100) 928 (f10 (quotient x 100) op) 929 (display " hundred" op) 930 (let ([x (remainder x 100)]) 931 (unless (= x 0) 932 (display " " op) 933 (f10 x op)))] 934 [else (f10 x op)])) 935 (define (f10 x op) 936 (cond 937 [(>= x 20) 938 (display (vector-ref v20 (quotient x 10)) op) 939 (let ([x (remainder x 10)]) 940 (unless (= x 0) 941 (display "-" op) 942 (f10 x op)))] 943 [else (display (vector-ref v0 x) op)])) 944 (define (f1000000 x op) 945 (cond 946 [(>= x 1000000) 947 (f100 (quotient x 1000000) op) 948 (display " million" op) 949 (let ([x (remainder x 1000000)]) 950 (unless (= x 0) 951 (display " " op) 952 (f1000 x op)))] 953 [else (f1000 x op)])) 954 (define (f1000 x op) 955 (cond 956 [(<= 1100 x 1999) (f100 x op)] 957 [(>= x 1000) 958 (f100 (quotient x 1000) op) 959 (display " thousand" op) 960 (let ([x (remainder x 1000)]) 961 (unless (= x 0) 962 (display " " op) 963 (f100 x op)))] 964 [else (f100 x op)])) 965 (define (*f1000000 x op) 966 (cond 967 [(>= x 1000000) 968 (f100 (quotient x 1000000) op) 969 (let ([x (remainder x 1000000)]) 970 (if (= x 0) 971 (display " millionth" op) 972 (begin 973 (display " million " op) 974 (*f1000 x op))))] 975 [else (*f1000 x op)])) 976 (define (*f1000 x op) 977 (cond 978 [(<= 1100 x 1999) (*f100 x op)] 979 [(>= x 1000) 980 (f100 (quotient x 1000) op) 981 (let ([x (remainder x 1000)]) 982 (if (= x 0) 983 (display " thousandth" op) 984 (begin 985 (display " thousand " op) 986 (*f100 x op))))] 987 [else (*f100 x op)])) 988 (define (*f100 x op) 989 (cond 990 [(>= x 100) 991 (f10 (quotient x 100) op) 992 (let ([x (remainder x 100)]) 993 (if (= x 0) 994 (display " hundredth" op) 995 (begin 996 (display " hundred " op) 997 (*f10 x op))))] 998 [else (*f10 x op)])) 999 (define (*f10 x op) 1000 (cond 1001 [(>= x 20) 1002 (let ([q (quotient x 10)] [x (remainder x 10)]) 1003 (if (= x 0) 1004 (display (vector-ref *v20 q) op) 1005 (begin 1006 (display (vector-ref v20 q) op) 1007 (display "-" op) 1008 (*f10 x op))))] 1009 [else (display (vector-ref *v0 x) op)])) 1010 (define v20 '#(#f #f twenty thirty forty fifty sixty seventy eighty ninety)) 1011 (define v0 '#(zero one two three four five six seven eight nine ten eleven twelve thirteen fourteen fifteen sixteen seventeen eighteen nineteen)) 1012 (define *v20 '#(#f #f twentieth thirtieth fortieth fiftieth sixtieth seventieth eightieth ninetieth)) 1013 (define *v0 '#(zeroth first second third fourth fifth sixth seventh eighth ninth tenth eleventh twelfth thirteenth fourteenth fifteenth sixteenth seventeenth eighteenth nineteenth)) 1014 (define (write-ordinal x op) 1015 (if (<= -999999999 x +999999999) 1016 (if (< x 0) 1017 (begin (display "minus " op) (*f1000000 (- x) op)) 1018 (*f1000000 x op)) 1019 (fprintf op "~:d~a" x 1020 (let ([n (remainder (abs x) 100)]) 1021 (if (<= 11 n 19) 1022 "th" 1023 (case (remainder n 10) 1024 [(1) "st"] 1025 [(2) "nd"] 1026 [(3) "rd"] 1027 [else "th"])))))) 1028 (define (write-cardinal x op) 1029 (if (<= -999999999 x +999999999) 1030 (if (< x 0) 1031 (begin (display "minus " op) (f1000000 (- x) op)) 1032 (f1000000 x op)) 1033 (fprintf op "~:d" x)))) 1034 (define cheap-scale 1035 (lambda (ls k) 1036 `(,(car ls) ,(fx+ (cadr ls) k) ,@(cddr ls)))) 1037 (define (do-fwrite-d op x w d k oc pc sign? ls) 1038 (let ([ls (cheap-scale ls k)]) 1039 (padnum w oc pc op 1040 (fd->string ls d 1041 (if (and w (fx< (cadr ls) 0) (fx> (fx+ (if (or sign? (fx= (car ls) -1)) 3 2) d) w)) 0 1) 1042 sign?)))) 1043 (define (do-fwrite op x w d k oc pc sign?) 1044 (cond 1045 [d (do-fwrite-d op x w d k oc pc sign? 1046 (flonum->digits x float-base 'absolute (fx- (fx+ k d))))] 1047 [w (padnum w oc pc op 1048 (let ([ls (cheap-scale (flonum->digits x float-base 'normal 0) k)]) 1049 (let ([s (car ls)] [e (cadr ls)]) 1050 (if (fx< e 0) 1051 (let ([n (fx+ w e (if (or sign? (fx< s 0)) -1 0))]) 1052 (let f ([ds (cddr ls)] [i n]) 1053 (if (fx<= i 0) 1054 (let ([ls (cheap-scale (flonum->digits x float-base 'absolute (fx- (fx+ k (fxmax (fx- n e 1) 1)))) k)]) 1055 (if (fx= (caddr ls) -1) ; rounded to zero? 1056 (if (fx< s 0) 1057 (if (fx< w 4) "-.0" "-0.0") 1058 (if sign? 1059 (if (fx< w 4) "+.0" "+0.0") 1060 (if (fx< w 3) ".0" "0.0"))) 1061 (fd->string ls #f 0 sign?))) 1062 (if (fx= (cadr ds) -1) ; can't be -2 w/normal 1063 (fd->string ls #f (if (fx= i 1) 0 1) sign?) 1064 (f (cdr ds) (fx- i 1)))))) 1065 (let ([n (fx+ w (if (or sign? (fx< s 0)) -2 -1))]) 1066 (let g ([e e] [ds (cddr ls)] [i n]) 1067 (if (fx< i 0) 1068 (if (fx< e -1) 1069 (fd->string (cheap-scale (flonum->digits x float-base 'absolute (fx- (fx+ e 2) k)) k) (and (fx= e -2) 0) 1 sign?) 1070 (fd->string (cheap-scale (flonum->digits x float-base 'absolute (fx- k)) k) 0 1 sign?)) 1071 (if (fx= (car ds) -1) ; can't be -2 w/normal 1072 (if (fx< e 0) 1073 (fd->string ls (and (fx= e -1) (fx= i 0) 0) 1 sign?) 1074 (if (fx< e (fx- i 1)) 1075 (fd->string (cheap-scale (flonum->digits x float-base 'absolute (fx- k (fx- i e))) k) #f 1 sign?) 1076 (fd->string (cheap-scale (flonum->digits x float-base 'absolute (fx- k)) k) 0 1 sign?))) 1077 (g (fx- e 1) (cdr ds) (fx- i 1))))))))))] 1078 [else (padnum w oc pc op 1079 (fd->string 1080 (let ([ls (cheap-scale (flonum->digits x float-base 'normal 0) k)]) 1081 (let f ([e (cadr ls)] [ds (cddr ls)]) 1082 (if (fx= (car ds) -1) ; w/normal, can't be -2 1083 (cheap-scale (flonum->digits x float-base 'absolute (fx- -1 k)) k) 1084 (if (fx< e 0) 1085 ls 1086 (f (fx- e 1) (cdr ds)))))) 1087 d 1 sign?))])) 1088 (define (do-ewrite op x w d ew k oc pc ec sign?) 1089 (cond 1090 [(fl= x 0.0) 1091 (padnum w oc pc op 1092 (let ([ss (if (fx= (flonum-sign x) 1) "-" (if sign? "+" ""))] 1093 [es (if ew (make-string ew #\0) "0")]) 1094 (let ([d (and d (if (fx<= k 0) d (fx+ (fx- d k) 1)))]) 1095 (if (and w (fx> (fx+ (string-length ss) 4 (or d 1) (string-length es)) w)) 1096 (if (if d (fx= d 0) (fx> k 0)) 1097 (string-append ss "0." (string ec) "+" es) 1098 (string-append ss "." (if d (make-string d #\0) "0") (string ec) "+" es)) 1099 (string-append ss "0." (if d (make-string d #\0) "0") (string ec) "+" es)))))] 1100 [d (let ([ls (flonum->digits x float-base 'relative (if (fx<= k 0) (fx- (fx+ d k)) (fx- -1 d)))]) 1101 (let* ([e (fx- (cadr ls) (fx- k 1))] 1102 [es (number->string (fxabs e))] 1103 [esl (string-length es)]) 1104 (if (and w oc ew (fx> esl ew)) 1105 (display (make-string w oc) op) 1106 (let ([ew (if ew (fxmax ew esl) esl)]) 1107 (padnum w oc pc op 1108 (string-append 1109 (fd->string 1110 `(,(car ls) ,(fx- k 1) ,@(cddr ls)) 1111 (if (fx<= k 0) d (fx+ (fx- d k) 1)) 1112 (if (and w (fx> (fx+ (if (or sign? (fx= (car ls) -1)) 5 4) ew d) w)) 0 1) 1113 sign?) 1114 (if ec (string ec) "e") 1115 (if (fx< e 0) "-" "+") 1116 (make-string (fx- ew esl) #\0) 1117 es))))))] 1118 [w (let ([sign? (or sign? (fx= (flonum-sign x) 1))]) 1119 (let loop ([ew-guess (or ew 1)]) 1120 (let d ([d (fxmax (fx- w (if sign? 5 4) ew-guess) 1121 (if (fx= k 0) 0 (if (fx< k 0) (fx- 1 k) (fx- k 1))))]) 1122 (let ([ls (flonum->digits x float-base 'relative (if (fx<= k 0) (fx- (fx+ d k)) (fx- -1 d)))]) 1123 (let* ([e (fx- (cadr ls) (fx- k 1))] 1124 [es (number->string (fxabs e))] 1125 [esl (string-length es)]) 1126 (if (fx> esl ew-guess) 1127 (if (and oc ew) 1128 (display (make-string w oc) op) 1129 (loop esl)) 1130 (let ([ew (if ew (fxmax ew esl) esl)]) 1131 (padnum w oc pc op 1132 (string-append 1133 (fd->string 1134 `(,(car ls) ,(fx- k 1) ,@(cddr ls)) 1135 (and (fx= (fx- k d) 1) (fx>= (fx+ (if sign? 5 4) ew d) w) 0) 1136 (if (fx> (fx+ (if sign? 5 4) ew d) w) 0 1) 1137 sign?) 1138 (if ec (string ec) "e") 1139 (if (fx< e 0) "-" "+") 1140 (make-string (fx- ew esl) #\0) 1141 es)))))))))] 1142 [else (display 1143 (let ([ls (flonum->digits x float-base 'normal 0)]) 1144 (let ([e (fx- (cadr ls) (fx- k 1))]) 1145 (string-append 1146 (fd->string `(,(car ls) ,(fx- k 1) ,@(cddr ls)) #f 1 sign?) 1147 (if ec (string ec) "e") 1148 (if (fx< e 0) "-" "+") 1149 (let ([op (open-output-string)]) 1150 (padnum ew #f #\0 op (number->string (fxabs e))) 1151 (get-output-string op))))) 1152 op)])) 1153 (define invalid-parameter 1154 (lambda (who cmd what p) 1155 ($oops who 1156 "invalid ~s parameter ~a in directive ~s" 1157 what p (fmt-directive cmd)))) 1158 (define (outer-loop cmd* arg* op cntl all-arg* super-arg* ct? succ fail) 1159 (define tostr 1160 (lambda (cmd* arg* super-arg* succ fail) 1161 (let ([op (open-output-string)]) 1162 (let ([xop (if ct? (make-format-port op) op)]) 1163 (outer-loop cmd* arg* xop cntl all-arg* super-arg* ct? 1164 (lambda (arg*) 1165 (when ct? (close-output-port xop)) 1166 (succ (get-output-string op) arg*)) 1167 (lambda (arg* super?) 1168 (when ct? (close-output-port xop)) 1169 (fail (get-output-string op) arg* super?))))))) 1170 (define next 1171 (lambda (arg*) 1172 (when (null? arg*) 1173 ($oops who "too few arguments for control string ~s" cntl)) 1174 (car arg*))) 1175 (let loop ([cmd* cmd*] [arg* arg*]) 1176 (if (null? cmd*) 1177 (succ arg*) 1178 (let ([cmd (car cmd*)]) 1179 (define-syntax vparams 1180 (lambda (x) 1181 (define process-param 1182 (lambda (arg* t* param* body) 1183 (if (null? param*) 1184 body 1185 (with-syntax ([body (process-param arg* (cdr t*) (cdr param*) body)] [arg* arg*] [t (car t*)]) 1186 (syntax-case (car param*) () 1187 [(type? p) 1188 #'(let-values ([(t arg*) 1189 (cond 1190 [(eq? t 'v) (let ([t (next arg*)]) 1191 (unless (type? t) (invalid-parameter who cmd 'p t)) 1192 (values t (cdr arg*)))] 1193 [(eq? t 'hash) (let ([t (length arg*)]) 1194 (unless (type? t) (invalid-parameter who cmd 'p t)) 1195 (values t arg*))] 1196 [else (values t arg*)])]) 1197 body)]))))) 1198 (syntax-case x () 1199 [(_ arg* ([t param] ...) e1 e2 ...) 1200 (process-param 1201 #'arg* 1202 #'(t ...) 1203 #'(param ...) 1204 #'(let () e1 e2 ...))]))) 1205 (cond 1206 [(string? cmd) (display-string cmd op) (loop (cdr cmd*) arg*)] 1207 [(char? cmd) (write-char cmd op) (loop (cdr cmd*) arg*)] 1208 [(fmt? cmd) 1209 (fmt-case cmd 1210 [simple-display () 1211 (display (next arg*) op) 1212 (loop (cdr cmd*) (cdr arg*))] 1213 [simple-write () 1214 (write (next arg*) op) 1215 (loop (cdr cmd*) (cdr arg*))] 1216 [fresh-line (n) 1217 (vparams arg* ([n (nnfixnum? n)]) 1218 (when (fx> n 0) 1219 (fresh-line op) 1220 (when (fx> n 1) 1221 (display (make-string (fx- n 1) #\newline) op))) 1222 (loop (cdr cmd*) arg*))] 1223 [display (mincol colinc minpad pad-char left?) 1224 (vparams arg* ([mincol (nnfixnum? mincol)] 1225 [colinc (pfixnum? colinc)] 1226 [minpad (nnfixnum? minpad)] 1227 [pad-char (char? pad-char)]) 1228 (pad mincol colinc minpad pad-char left? op 1229 (display (next arg*) op)) 1230 (loop (cdr cmd*) (cdr arg*)))] 1231 [write (mincol colinc minpad pad-char nogensym? left?) 1232 (vparams arg* ([mincol (nnfixnum? mincol)] 1233 [colinc (pfixnum? colinc)] 1234 [minpad (nnfixnum? minpad)] 1235 [pad-char (char? pad-char)]) 1236 (pad mincol colinc minpad pad-char left? op 1237 (if nogensym? 1238 (parameterize ([print-gensym #f]) 1239 (write (next arg*) op)) 1240 (write (next arg*) op))) 1241 (loop (cdr cmd*) (cdr arg*)))] 1242 [cwrite (colon? at?) 1243 (let ([c (next arg*)]) 1244 (unless (char? c) 1245 ($oops who "expected character for ~~c, received ~s" c)) 1246 (if colon? 1247 (let ([x (char-name c)]) 1248 (if x 1249 (begin 1250 (write-char #\< op) 1251 (display x op) 1252 (write-char #\> op)) 1253 (let ([n (char->integer c)]) 1254 (if (fx< n #x20) 1255 (begin 1256 (write-char #\^ op) 1257 (write-char (integer->char (fx+ n #x40)) op)) 1258 (write-char c op))))) 1259 (if at? 1260 (write c op) 1261 (write-char c op)))) 1262 (loop (cdr cmd*) (cdr arg*))] 1263 [fwrite (w d k oc pc sign?) 1264 (vparams arg* ([w (nnfixnum? w)] 1265 [d (nnfixnum? d)] 1266 [k (fixnum? k)] 1267 [oc (char? overflow-char)] 1268 [pc (char? pad-char)]) 1269 (let ([x (next arg*)]) 1270 (unless (real? x) 1271 ($oops who "expected real number for ~~f, received ~s" x)) 1272 (let ([x (inexact x)]) 1273 (if (exceptional-flonum? x) 1274 (padnum w oc pc op (number->string x)) 1275 (do-fwrite op x w d k oc pc sign?)))) 1276 (loop (cdr cmd*) (cdr arg*)))] 1277 [ewrite (w d ew k oc pc ec sign?) 1278 (vparams arg* ([w (nnfixnum? w)] 1279 [d (nnfixnum? d)] 1280 [ew (nnfixnum? e)] 1281 [k (fixnum? k)] 1282 [oc (char? overflow-char)] 1283 [pc (char? pad-char)] 1284 [ec (char? exponent-char)]) 1285 (let ([x (next arg*)]) 1286 (unless (real? x) 1287 ($oops who "expected real number for ~~e, received ~s" x)) 1288 (let ([x (inexact x)]) 1289 (if (exceptional-flonum? x) 1290 (padnum w oc pc op (number->string x)) 1291 (if (or (not d) (fx< (fx- d) k (fx+ d 2))) 1292 (do-ewrite op x w d ew k oc pc ec sign?) 1293 ; signaling an error might be kind, but cltl2 says otherwise 1294 (if (and w oc) 1295 (display (make-string w oc) op) 1296 (let ([d (if (fx> k 0) (fx- k 1) (fx- 1 k))]) 1297 (do-ewrite op x w d ew k oc pc ec sign?))))))) 1298 (loop (cdr cmd*) (cdr arg*)))] 1299 [gwrite (w d ew k oc pc ec sign?) 1300 (vparams arg* ([w (nnfixnum? w)] 1301 [d (nnfixnum? d)] 1302 [ew (nnfixnum? e)] 1303 [k (fixnum? k)] 1304 [oc (char? overflow-char)] 1305 [pc (char? pad-char)] 1306 [ec (char? exponent-char)]) 1307 (let ([x (next arg*)]) 1308 #;(define (ilog x) (fx+ (cadr (flonum->digits x float-base 'normal 0)) 1)) 1309 (define (ilog x) ; 4x faster and good enough 1310 (if (fl= x 0.0) 1311 0 1312 (fx+ (flonum->fixnum (floor (fl- (fl* (log (flabs x)) (fl/ (log 10))) 1e-10))) 1))) 1313 (define significant-digits 1314 (lambda (ls) 1315 (if (fx< (car ls) 0) 1316 0 1317 (fx+ 1 (significant-digits (cdr ls)))))) 1318 (unless (real? x) 1319 ($oops who "expected real number for ~~g, received ~s" x)) 1320 (let ([x (inexact x)]) 1321 (if (exceptional-flonum? x) 1322 (padnum w oc pc op (number->string x)) 1323 (if d 1324 (let f ([n (ilog x)]) ; can x be negative here? 1325 (let ([dd (fx- d n)]) 1326 (if (not (fx<= 0 dd d)) 1327 (do-ewrite op x w d ew k oc pc ec sign?) 1328 (let ([ls (flonum->digits x float-base 'absolute (fx- dd))]) 1329 (let ([actual-n (fx+ (cadr ls) 1)]) 1330 (if (fx> actual-n n) ; e.g., .9999 came back as 1.000 1331 (f actual-n) 1332 (let* ([ee (if ew (fx+ ew 2) 4)] 1333 [ww (and w (fx- w ee))]) 1334 ; scale k not used when treated as ~f 1335 (do-fwrite-d op x ww dd 0 oc pc sign? ls) 1336 (when w (display (make-string ee #\space) op))))))))) 1337 (let* ([ls (flonum->digits x float-base 'normal 0)] 1338 [n (fx+ (cadr ls) 1)] 1339 [est-d (max (significant-digits (cddr ls)) (min n 7))] 1340 [dd (fx- est-d n)]) 1341 (if (fx<= 0 dd est-d) 1342 (let* ([ee (if ew (fx+ ew 2) 4)] 1343 [ww (and w (fx- w ee))]) 1344 ; scale k not used when treated as ~f 1345 (do-fwrite op x ww dd 0 oc pc sign?) 1346 ; suppressing trailing whitespace when (not w) 1347 (when w (display (make-string ee #\space) op))) 1348 ; cltl seems to want our estimated d here (est-d) 1349 ; but original d (#f) makes more sense 1350 (do-ewrite op x w d ew k oc pc ec sign?))))))) 1351 (loop (cdr cmd*) (cdr arg*)))] 1352 [$write (d n w pc sign-before-pad? sign?) 1353 (vparams arg* ([d (nnfixnum? d)] 1354 [n (nnfixnum? n)] 1355 [w (nnfixnum? w)] 1356 [pc (char? pad-char)]) 1357 (let ([x (next arg*)]) 1358 (unless (real? x) 1359 ($oops who "expected real number for ~~$, received ~s" x)) 1360 (let ([x (inexact x)]) 1361 (if (exceptional-flonum? x) 1362 (padnum w #f pc op (number->string x)) 1363 (let ([ls (flonum->digits x float-base 'absolute (fx- d))]) 1364 (if (and sign-before-pad? (or sign? (fx= (car ls) -1))) 1365 (begin 1366 (write-char (if (fx= (car ls) -1) #\- #\+) op) 1367 (padnum (fx- w 1) #f pc op 1368 (fd->string (cons 1 (cdr ls)) d n #f))) 1369 (padnum w #f pc op 1370 (fd->string ls d n sign?))))))) 1371 (loop (cdr cmd*) (cdr arg*)))] 1372 [write-radix (base w pc cc ci sign? commas?) 1373 (vparams arg* ([base (radix? n)] 1374 [w (nnfixnum? w)] 1375 [pc (char? pad-char)] 1376 [cc (char? comma-char)] 1377 [ci (pfixnum? comma-interval)]) 1378 (let ([x (next arg*)]) 1379 (padnum w #f pc op 1380 (cond 1381 [(exact-integer? x) 1382 (let* ([s (number->string x base)] 1383 [s (if (and sign? (>= x 0)) (string-append "+" s) s)]) 1384 (if commas? 1385 (let* ([n (string-length s)] 1386 [sign (let ([c (string-ref s 0)]) 1387 (and (memv c '(#\+ #\-)) c))] 1388 [m (if sign (fx- n 1) n)] 1389 [nc (fxquotient (fx- m 1) ci)] 1390 [s2 (make-string (fx+ n nc))] 1391 [k (fxremainder m ci)] 1392 [k (if (fx= k 0) ci k)]) 1393 (define (loop i j k) 1394 (cond 1395 [(fx= i n) s2] 1396 [(fx= k 0) 1397 (string-set! s2 j cc) 1398 (loop i (fx+ j 1) ci)] 1399 [else 1400 (string-set! s2 j (string-ref s i)) 1401 (loop (fx+ i 1) (fx+ j 1) (fx- k 1))])) 1402 (cond 1403 [sign 1404 (string-set! s2 0 sign) 1405 (loop 1 1 k)] 1406 [else (loop 0 0 k)])) 1407 s))] 1408 [else 1409 (let ([op (open-output-string)]) 1410 (parameterize ([print-radix base]) 1411 (display x op)) 1412 (get-output-string op))]))) 1413 (loop (cdr cmd*) (cdr arg*)))] 1414 [plural (back-up? y/ies?) 1415 (let ([arg* (if back-up? 1416 (let f ([prev #f] [ls all-arg*]) 1417 (if (eq? ls arg*) 1418 (if prev 1419 prev 1420 ($oops who "no previous argument for ~a" (fmt-directive (car cmd*)))) 1421 (f ls (cdr ls)))) 1422 arg*)]) 1423 (if (eqv? (next arg*) 1) 1424 (when y/ies? (write-char #\y op)) 1425 (if y/ies? 1426 (display "ies" op) 1427 (write-char #\s op))) 1428 (loop (cdr cmd*) (cdr arg*)))] 1429 [fancy-radix (colon? at?) 1430 (let ([x (next arg*)]) 1431 (unless (exact-integer? x) 1432 ($oops who "expected exact integer for ~~r, received ~s" x)) 1433 (if colon? 1434 (if at? 1435 (write-old-roman x op) 1436 (write-ordinal x op)) 1437 (if at? 1438 (write-roman x op) 1439 (write-cardinal x op)))) 1440 (loop (cdr cmd*) (cdr arg*))] 1441 [dup-char (n c) 1442 (vparams arg* ([n (nnfixnum? n)]) 1443 (display (make-string n c) op) 1444 (loop (cdr cmd*) arg*))] 1445 [tabulate (colnum colinc relative?) 1446 (vparams arg* ([colnum (nnfixnum? colnum)] 1447 [colinc (nnfixnum? colinc)]) 1448 (cond 1449 [relative? 1450 (display (make-string colnum #\space) op) 1451 (unless (= colinc 0) 1452 (let ([col (output-column op)]) 1453 (when col 1454 (let ([n (modulo col colinc)]) 1455 (unless (= n 0) 1456 (display (make-string (- colinc n) #\space) op))))))] 1457 [else 1458 (let ([col (output-column op)]) 1459 (if col 1460 (if (>= col colnum) 1461 (unless (= colinc 0) 1462 (display (make-string (- colinc (modulo (- col colnum) colinc)) #\space) op)) 1463 (display (make-string (- colnum col) #\space) op)) 1464 (display " " op)))]) 1465 (loop (cdr cmd*) arg*))] 1466 [indirect (splice?) 1467 (let ([xcntl (next arg*)]) 1468 (unless (string? xcntl) 1469 ($oops who "first ~a argument ~s is not a string" (fmt-directive (car cmd*)) xcntl)) 1470 (let-values ([(xcmd* expected) (parse who xcntl)]) 1471 (if splice? 1472 (outer-loop xcmd* (cdr arg*) op cntl all-arg* #f ct? 1473 (lambda (arg*) (loop (cdr cmd*) arg*)) 1474 (lambda (arg* super?) (loop (cdr cmd*) arg*))) 1475 (let* ([arg* (cdr arg*)] 1476 [xarg* (next arg*)]) 1477 (let ([len ($list-length xarg* who)]) 1478 (when (and indirect-too-many-args-check expected) 1479 (check-nargs who expected len xcntl))) 1480 (outer-loop xcmd* xarg* op xcntl xarg* #f ct? 1481 (lambda (xarg*) 1482 (when (and dynamic-too-many-args-check (not (null? xarg*))) 1483 ($oops who "too many arguments for control string ~s" xcntl)) 1484 (loop (cdr cmd*) (cdr arg*))) 1485 (lambda (xarg* super?) 1486 (loop (cdr cmd*) (cdr arg*))))))))] 1487 [conditional (n cases default) 1488 (vparams arg* ([n (nnfixnum? n)]) 1489 (let-values ([(n arg*) (if n (values n arg*) (let ([n (next arg*)]) (values n (cdr arg*))))]) 1490 (loop 1491 (append (if (and (fixnum? n) (fx<= 0 n) (fx< n (vector-length cases))) 1492 (vector-ref cases n) 1493 default) 1494 (cdr cmd*)) 1495 arg*)))] 1496 [conditional/colon (alternative consequent) 1497 (let ([arg (next arg*)]) 1498 (loop (append (if arg consequent alternative) (cdr cmd*)) 1499 (cdr arg*)))] 1500 [conditional/at (consequent) 1501 (if (next arg*) 1502 (loop (append consequent (cdr cmd*)) arg*) 1503 (loop (cdr cmd*) (cdr arg*)))] 1504 [justify (mincol colinc minpad pc before? after? initial margin columns segments) 1505 (vparams arg* ([mincol (nnfixnum? mincol)] 1506 [colinc (nnfixnum? colinc)] 1507 [minpad (nnfixnum? minpad)] 1508 [pc (char? pad-char)]) 1509 (let () 1510 (define (process-segments initial complete segments arg*) 1511 (if (null? segments) 1512 (finalize initial (reverse complete) arg*) 1513 (tostr (car segments) arg* #f 1514 (lambda (s arg*) (process-segments initial (cons s complete) (cdr segments) arg*)) 1515 (lambda (s arg* super?) (finalize initial (reverse complete) arg*))))) 1516 (define (finalize initial segments arg*) 1517 (let* ([chars (apply fx+ (map string-length segments))] 1518 [segments (if before? 1519 (if after? 1520 `("" ,@segments "") 1521 `("" ,@segments)) 1522 (if after? 1523 `(,@segments "") 1524 (if (null? segments) 1525 '("") 1526 segments)))] 1527 [npads (fx- (length segments) 1)] 1528 [size (fx+ chars (fx* minpad npads))] 1529 [size (if (fx<= size mincol) 1530 mincol 1531 (fx+ size (fxmodulo (fx- mincol size) colinc)))]) 1532 (when initial 1533 (let ([oc (output-column op)]) 1534 (when (and oc (fx> (fx+ oc size margin) columns)) 1535 (display initial op)))) 1536 (cond 1537 [(fx= npads 0) ; right justify single item 1538 (display (make-string (fx- size chars) pc) op) 1539 (display (car segments) op)] 1540 [else 1541 (let* ([pad-amt (fx- size chars)] 1542 [pad-q (fxquotient pad-amt npads)] 1543 [pad-r (fxremainder pad-amt npads)] 1544 [pad-i (if (fx= pad-r 0) 0 (fxquotient npads pad-r))]) 1545 (let f ([s (car segments)] [s* (cdr segments)] [i 1] [pad-r pad-r]) 1546 (display s op) 1547 (unless (null? s*) 1548 (cond 1549 [(and (fx> pad-r 0) (fx= i 1)) 1550 (display (make-string (fx+ pad-q 1) pc) op) 1551 (f (car s*) (cdr s*) pad-i (fx- pad-r 1))] 1552 [else 1553 (display (make-string pad-q pc) op) 1554 (f (car s*) (cdr s*) (fx- i 1) pad-r)]))))])) 1555 (loop (cdr cmd*) arg*)) 1556 (if initial 1557 (tostr initial arg* #f 1558 (lambda (initial arg*) (process-segments initial '() segments arg*)) 1559 (lambda (s arg* super?) (finalize #f '() arg*))) 1560 (process-segments #f '() segments arg*))))] 1561 [goto (n reverse? absolute?) 1562 (vparams arg* ([n (nnfixnum? n)]) 1563 (loop (cdr cmd*) 1564 (cond 1565 [absolute? 1566 (let ([n (or n 0)]) 1567 (unless (fx<= n (length all-arg*)) 1568 ($oops who "~a would move beyond argument list" (fmt-directive (car cmd*)))) 1569 (list-tail all-arg* n))] 1570 [reverse? 1571 (let ([n (or n 1)]) 1572 (let ([n (fx- (length all-arg*) (length arg*) n)]) 1573 (unless (fx>= n 0) 1574 ($oops who "~a would move before first argument" (fmt-directive (car cmd*)))) 1575 (list-tail all-arg* n)))] 1576 [else 1577 (let ([n (or n 1)]) 1578 (unless (fx<= n (length arg*)) 1579 ($oops who "~a would move beyond argument list" (fmt-directive (car cmd*)))) 1580 (list-tail arg* n))])))] 1581 [convert-case (nested-cmd* colon? at?) 1582 (let () 1583 (define convert-display 1584 (lambda (s) 1585 (if colon? 1586 (if at? 1587 (string-upcase! s) 1588 (string-capitalize! s)) 1589 (if at? 1590 (string-capitalize-first! s) 1591 (string-downcase! s))) 1592 (display s op))) 1593 (tostr nested-cmd* arg* super-arg* 1594 (lambda (s arg*) (convert-display s) (loop (cdr cmd*) arg*)) 1595 (lambda (s arg* super?) (convert-display s) (fail arg* super?))))] 1596 [iteration (body n sublists? use-remaining? at-least-once?) 1597 (vparams arg* ([n (nnfixnum? n)]) 1598 (let-values ([(body body-cntl body-expected arg*) 1599 (if (null? body) 1600 (let ([arg (next arg*)]) 1601 (let-values ([(cmd* expected) (parse who arg)]) 1602 (values cmd* arg expected (cdr arg*)))) 1603 (values body cntl #f arg*))]) 1604 (if use-remaining? 1605 (if sublists? 1606 (let f ([n n] [arg* arg*] [at-least-once? at-least-once?]) 1607 (if (or (and n (fx= n 0)) (and (not at-least-once?) (null? arg*))) 1608 (loop (cdr cmd*) arg*) 1609 (let-values ([(xarg* arg*) (if (null? arg*) (values '() '()) (values (car arg*) (cdr arg*)))]) 1610 (let ([len ($list-length xarg* who)]) 1611 (when (and indirect-too-many-args-check body-expected) 1612 (check-nargs who body-expected len body-cntl))) 1613 (outer-loop body xarg* op body-cntl xarg* arg* ct? 1614 (lambda (xarg*) 1615 (when (and dynamic-too-many-args-check (not (null? xarg*))) 1616 ($oops who "too many arguments for control string ~s" body-cntl)) 1617 (f (and n (fx- n 1)) arg* #f)) 1618 (lambda (xarg* super?) 1619 (if super? 1620 (loop (cdr cmd*) arg*) 1621 (f (and n (fx- n 1)) arg* #f))))))) 1622 (let f ([n n] [arg* arg*] [at-least-once? at-least-once?]) 1623 (if (or (and n (fx= n 0)) (and (not at-least-once?) (null? arg*))) 1624 (loop (cdr cmd*) arg*) 1625 (outer-loop body arg* op body-cntl all-arg* #f ct? 1626 (lambda (arg*) (f (and n (fx- n 1)) arg* #f)) 1627 (lambda (arg* super?) (f (and n (fx- n 1)) arg* #f)))))) 1628 (let ([all-larg* (next arg*)]) 1629 (unless (list? all-larg*) 1630 ($oops who "~s is not a proper list" all-larg*)) 1631 (if sublists? 1632 (let f ([n n] [larg* all-larg*] [at-least-once? at-least-once?]) 1633 (if (or (and n (fx= n 0)) (and (not at-least-once?) (null? larg*))) 1634 (loop (cdr cmd*) (cdr arg*)) 1635 (let-values ([(xarg* larg*) (if (null? larg*) (values '() '()) (values (car larg*) (cdr larg*)))]) 1636 (let ([len ($list-length xarg* who)]) 1637 (when (and indirect-too-many-args-check body-expected) 1638 (check-nargs who body-expected len body-cntl))) 1639 (outer-loop body xarg* op body-cntl xarg* larg* ct? 1640 (lambda (xarg*) 1641 (when (and dynamic-too-many-args-check (not (null? xarg*))) 1642 ($oops who "too many arguments for control string ~s" body-cntl)) 1643 (f (and n (fx- n 1)) larg* #f)) 1644 (lambda (xarg* super?) 1645 (if super? 1646 (loop (cdr cmd*) (cdr arg*)) 1647 (f (and n (fx- n 1)) larg* #f))))))) 1648 (let f ([n n] [larg* all-larg*] [at-least-once? at-least-once?]) 1649 (if (or (and n (fx= n 0)) (and (not at-least-once?) (null? larg*))) 1650 (loop (cdr cmd*) (cdr arg*)) 1651 (outer-loop body larg* op body-cntl all-larg* #f ct? 1652 (lambda (larg*) (f (and n (fx- n 1)) larg* #f)) 1653 (lambda (larg* super?) (f (and n (fx- n 1)) larg* #f))))))))))] 1654 [abort (n m super?) 1655 (vparams arg* ([n (true? n)] [m (true? m)]) 1656 (if (if n 1657 (if m (eqv? n m) (eqv? n 0)) 1658 (null? (if super? super-arg* arg*))) 1659 (fail arg* super?) 1660 (loop (cdr cmd*) arg*)))] 1661 [columntrack (body) 1662 (let ([xop (make-format-port op)]) 1663 (outer-loop body arg* xop cntl arg* super-arg* #t 1664 (lambda (arg*) 1665 (close-output-port xop) 1666 (outer-loop (cdr cmd*) arg* op cntl arg* super-arg* ct? succ fail)) 1667 (lambda (arg* super?) 1668 (close-output-port xop) 1669 (fail arg* super?))))] 1670 [else ($oops who "internal error: ~s" cmd)])] 1671 [else ($oops who "internal error: ~s" cmd)]))))) 1672 (let ([op (or fmt-op (open-output-string))]) 1673 (outer-loop cmd* arg* op cntl arg* #f #f 1674 (lambda (arg*) 1675 (when (and dynamic-too-many-args-check (not (null? arg*))) 1676 ($oops who "too many arguments for control string ~s" cntl)) 1677 (void)) 1678 (lambda (arg* super?) (void))) 1679 (unless fmt-op (get-output-string op))))) 1680 1681 (define check-nargs 1682 (lambda (who expected received cntl) 1683 (when (and expected received) 1684 (unless (fx= expected received) 1685 (if (fx< received expected) 1686 ($oops who "too few arguments for control string ~s" cntl) 1687 ($oops who "too many arguments for control string ~s" cntl)))))) 1688 1689 (define format-port-name "format port") 1690 (define (output-column p) 1691 (unless (eq? (port-name p) format-port-name) 1692 ($oops 'format "internal error: port is not a format port")) 1693 ((port-handler p) 'column p)) 1694 1695 (define make-format-port 1696 (lambda (subop) 1697 (define column 0) 1698 (define update-column! 1699 (lambda (p s n) 1700 (let f ([i 0] [col 0] [newline? #f]) 1701 (if (fx= i n) 1702 (begin 1703 (set! column (if newline? col (+ column col))) 1704 (set-port-bol! p newline?)) 1705 (if (char=? (string-ref s i) #\newline) 1706 (f (fx+ i 1) 0 #t) 1707 (f (fx+ i 1) (fx+ col 1) newline?)))))) 1708 (define handler 1709 (message-lambda 1710 (lambda (msg . args) ($oops 'format-port "operation ~s not handled" msg)) 1711 [(block-write p s n) 1712 (flush-output-port p) 1713 (update-column! p s n) 1714 (block-write subop s n)] 1715 [(clear-output-port p) (set-textual-port-output-index! p 0)] 1716 [(close-port p) 1717 (flush-output-port p) 1718 (set-textual-port-output-size! p 0) 1719 (mark-port-closed! p)] 1720; [(file-length p) #f] 1721 [(file-position p) (most-negative-fixnum)] 1722 [(file-position p pos) ($oops 'format-port "cannot reposition")] 1723 [(flush-output-port p) 1724 (let ([b (textual-port-output-buffer p)] 1725 [i (textual-port-output-index p)]) 1726 (unless (fx= i 0) 1727 (update-column! p b i) 1728 (block-write subop b i))) 1729 (set-textual-port-output-index! p 0)] 1730 [(port-name p) format-port-name] 1731 [(write-char c p) 1732 (let ([b (textual-port-output-buffer p)] 1733 [i (textual-port-output-index p)]) 1734 (string-set! b i c) 1735 (block-write subop b (fx+ i 1))) 1736 (set-textual-port-output-index! p 0)] 1737 [(column p) (flush-output-port p) column])) 1738 (let ([len 1024]) 1739 (let ([p (make-output-port handler (make-string len))]) 1740 (set-textual-port-output-size! p (fx- len 1)) 1741 (set-port-bol! p #t) 1742 p)))) 1743 1744 (define go 1745 (lambda (who op cntl args) 1746 (let-values ([(cmd* expected) (parse who cntl)]) 1747 (when static-too-many-args-check 1748 (check-nargs who expected (length args) cntl)) 1749 (dofmt who op cntl cmd* args)))) 1750 1751 (set! format 1752 (case-lambda 1753 [(port/cntl cntl/arg . args) 1754 (cond 1755 [(port? port/cntl) 1756 (unless (and (output-port? port/cntl) (textual-port? port/cntl)) 1757 ($oops 'format "~s is not a textual output port" port/cntl)) 1758 (go 'format port/cntl cntl/arg args)] 1759 [(eq? port/cntl #t) (go 'format (current-output-port) cntl/arg args)] 1760 [(eq? port/cntl #f) (go 'format #f cntl/arg args)] 1761 [else (go 'format #f port/cntl (cons cntl/arg args))])] 1762 [(cntl . args) (go 'format #f cntl args)])) 1763 1764 (set! $dofmt dofmt) 1765 1766 (set! $make-fmt->expr make-fmt->expr) 1767 1768 (set! $parse-format-string 1769 (lambda (who cntl received) 1770 (let-values ([(cmd* expected) (parse who cntl)]) 1771 (when static-too-many-args-check 1772 (check-nargs who expected received cntl)) 1773 (squash cmd*)))) 1774 1775 (set! printf 1776 (lambda (cntl . args) 1777 (go 'printf (current-output-port) cntl args))) 1778 1779 (set! fprintf 1780 (lambda (op cntl . args) 1781 (unless (and (output-port? op) (textual-port? op)) 1782 ($oops 'fprintf "~s is not a textual output port" op)) 1783 (go 'fprintf op cntl args)))) 1784