home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / format.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  56.4 KB  |  1,691 lines
  1. ;;;; "format.scm" Common LISP text output formatter for SLIB
  2. ;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
  3. ;;; Assimilated into Guile May 1999
  4. ;;
  5. ;; This code is in the public domain.
  6.  
  7. ;; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
  8. ;; Please send error reports to bug-guile@gnu.org.
  9. ;; For documentation see slib.texi and format.doc.
  10. ;; For testing load formatst.scm.
  11. ;;
  12. ;; Version 3.0
  13.  
  14. (define-module (ice-9 format)
  15.   :use-module (ice-9 and-let-star)
  16.   :autoload (ice-9 pretty-print) (pretty-print)
  17.   :replace (format)
  18.   :export (format:symbol-case-conv
  19.        format:iobj-case-conv
  20.        format:expch))
  21.  
  22. ;;; Configuration ------------------------------------------------------------
  23.  
  24. (define format:symbol-case-conv #f)
  25. ;; Symbols are converted by symbol->string so the case of the printed
  26. ;; symbols is implementation dependent. format:symbol-case-conv is a
  27. ;; one arg closure which is either #f (no conversion), string-upcase!,
  28. ;; string-downcase! or string-capitalize!.
  29.  
  30. (define format:iobj-case-conv #f)
  31. ;; As format:symbol-case-conv but applies for the representation of
  32. ;; implementation internal objects.
  33.  
  34. (define format:expch #\E)
  35. ;; The character prefixing the exponent value in ~e printing.
  36.  
  37. (define format:floats (provided? 'inexact))
  38. ;; Detects if the scheme system implements flonums (see at eof).
  39.  
  40. (define format:complex-numbers (provided? 'complex))
  41. ;; Detects if the scheme system implements complex numbers.
  42.  
  43. (define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
  44. ;; Detects if number->string adds a radix prefix.
  45.  
  46. (define format:ascii-non-printable-charnames
  47.   '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
  48.      "bs"  "ht"  "nl"  "vt"  "np"  "cr"  "so"  "si"
  49.      "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
  50.      "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us" "space"))
  51.  
  52. ;;; End of configuration ----------------------------------------------------
  53.  
  54. (define (format . args)
  55.   (letrec
  56.       ((format:version "3.0")
  57.        (format:port #f)            ; curr. format output port
  58.        (format:output-col 0)        ; curr. format output tty column
  59.        (format:flush-output #f)        ; flush output at end of formatting
  60.        (format:case-conversion #f)
  61.        (format:args #f)
  62.        (format:pos 0)            ; curr. format string parsing position
  63.        (format:arg-pos 0)        ; curr. format argument position
  64.                     ; this is global for error presentation
  65.        
  66.        ;; format string and char output routines on format:port
  67.  
  68.        (format:out-str
  69.     (lambda (str)
  70.       (if format:case-conversion
  71.           (display (format:case-conversion str) format:port)
  72.           (display str format:port))
  73.       (set! format:output-col
  74.         (+ format:output-col (string-length str)))))
  75.  
  76.        (format:out-char
  77.     (lambda (ch)
  78.       (if format:case-conversion
  79.           (display (format:case-conversion (string ch))
  80.                format:port)
  81.           (write-char ch format:port))
  82.       (set! format:output-col
  83.         (if (char=? ch #\newline)
  84.             0
  85.             (+ format:output-col 1)))))
  86.        
  87.        ;;(define (format:out-substr str i n)  ; this allocates a new string
  88.        ;;  (display (substring str i n) format:port)
  89.        ;;  (set! format:output-col (+ format:output-col n)))
  90.  
  91.        (format:out-substr
  92.     (lambda (str i n)
  93.       (do ((k i (+ k 1)))
  94.           ((= k n))
  95.         (write-char (string-ref str k) format:port))
  96.       (set! format:output-col (+ format:output-col (- n i)))))
  97.  
  98.        ;;(define (format:out-fill n ch)       ; this allocates a new string
  99.        ;;  (format:out-str (make-string n ch)))
  100.  
  101.        (format:out-fill
  102.     (lambda (n ch)
  103.       (do ((i 0 (+ i 1)))
  104.           ((= i n))
  105.         (write-char ch format:port))
  106.       (set! format:output-col (+ format:output-col n))))
  107.  
  108.        ;; format's user error handler
  109.  
  110.        (format:error
  111.     (lambda args        ; never returns!
  112.       (let ((format-args format:args)
  113.         (port (current-error-port)))
  114.         (set! format:error format:intern-error)
  115.         (if (and (>= (length format:args) 2)
  116.              (string? (cadr format:args)))
  117.         (let ((format-string (cadr format-args)))
  118.           (if (not (zero? format:arg-pos))
  119.               (set! format:arg-pos (- format:arg-pos 1)))
  120.           (format port
  121.               "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
  122.                                   ~{~a ~}===>~{~a ~})~%        "
  123.               (car format:args)
  124.               (substring format-string 0 format:pos)
  125.               (substring format-string format:pos
  126.                      (string-length format-string))
  127.               (list-head (cddr format:args) format:arg-pos)
  128.               (list-tail (cddr format:args) format:arg-pos)))
  129.         (format port 
  130.             "~%FORMAT: error with call: (format~{ ~a~})~%        "
  131.             format:args))
  132.         (apply format port args)
  133.         (newline port)
  134.         (set! format:error format:error-save)
  135.         (format:abort))))
  136.  
  137.        (format:intern-error
  138.     (lambda args
  139.       ;;if something goes wrong in format:error
  140.       (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
  141.       (display "        format args: ") (write format:args) (newline)
  142.       (display "        error args:  ") (write args) (newline)
  143.       (set! format:error format:error-save)
  144.       (format:abort)))
  145.           
  146.        (format:error-save #f)
  147.  
  148.        (format:format
  149.     (lambda args        ; the formatter entry
  150.       (set! format:args args)
  151.       (set! format:arg-pos 0)
  152.       (set! format:pos 0)
  153.       (if (< (length args) 1)
  154.           (format:error "not enough arguments"))
  155.  
  156.       ;; If the first argument is a string, then that's the format string.
  157.       ;; (Scheme->C)
  158.       ;; In this case, put the argument list in canonical form.
  159.       (let ((args (if (string? (car args))
  160.               (cons #f args)
  161.               args)))
  162.         ;; Use this canonicalized version when reporting errors.
  163.         (set! format:args args)
  164.  
  165.         (let ((destination (car args))
  166.           (arglist (cdr args)))
  167.           (cond
  168.            ((or (and (boolean? destination)    ; port output
  169.              destination)
  170.             (output-port? destination)
  171.             (number? destination))
  172.         (format:out (cond
  173.                  ((boolean? destination) (current-output-port))
  174.                  ((output-port? destination) destination)
  175.                  ((number? destination) (current-error-port)))
  176.                 (car arglist) (cdr arglist)))
  177.            ((and (boolean? destination)    ; string output
  178.              (not destination))
  179.         (call-with-output-string
  180.          (lambda (port) (format:out port (car arglist) (cdr arglist)))))
  181.            (else
  182.         (format:error "illegal destination `~a'" destination)))))))
  183.  
  184.        (format:out                              ; the output handler for a port
  185.     (lambda (port fmt args)    
  186.       (set! format:port port)        ; global port for
  187.                     ; output routines
  188.       (set! format:case-conversion #f)    ; modifier case
  189.                     ; conversion procedure
  190.       (set! format:flush-output #f)        ; ~! reset
  191.       (and-let* ((col (port-column port)))    ; get current column from port
  192.             (set! format:output-col col))
  193.       (let ((arg-pos (format:format-work fmt args))
  194.         (arg-len (length args)))
  195.         (cond
  196.          ((> arg-pos arg-len)
  197.           (set! format:arg-pos (+ arg-len 1))
  198.           (display format:arg-pos)
  199.           (format:error "~a missing argument~:p" (- arg-pos arg-len)))
  200.          (else
  201.           (if format:flush-output (force-output port))
  202.           #t)))))
  203.  
  204.        (format:parameter-characters
  205.     '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
  206.  
  207.        (format:format-work ; does the formatting work
  208.     (lambda (format-string arglist)
  209.       (letrec
  210.           ((format-string-len (string-length format-string))
  211.            (arg-pos 0)            ; argument position in arglist
  212.            (arg-len (length arglist))    ; number of arguments
  213.            (modifier #f)            ; 'colon | 'at | 'colon-at | #f
  214.            (params '())            ; directive parameter list
  215.            (param-value-found #f)        ; a directive
  216.                     ; parameter value
  217.                     ; found
  218.            (conditional-nest 0)        ; conditional nesting level
  219.            (clause-pos 0)            ; last cond. clause
  220.                     ; beginning char pos
  221.            (clause-default #f)        ; conditional default
  222.                     ; clause string
  223.            (clauses '())            ; conditional clause
  224.                     ; string list
  225.            (conditional-type #f)        ; reflects the
  226.                     ; contional modifiers
  227.            (conditional-arg #f)        ; argument to apply the conditional
  228.            (iteration-nest 0)        ; iteration nesting level
  229.            (iteration-pos 0)        ; iteration string
  230.                     ; beginning char pos
  231.            (iteration-type #f)        ; reflects the
  232.                     ; iteration modifiers
  233.            (max-iterations #f)        ; maximum number of
  234.                     ; iterations
  235.            (recursive-pos-save format:pos)
  236.            
  237.            (next-char            ; gets the next char
  238.                     ; from format-string
  239.         (lambda ()
  240.           (let ((ch (peek-next-char)))
  241.             (set! format:pos (+ 1 format:pos))
  242.             ch)))
  243.            
  244.            (peek-next-char
  245.         (lambda ()
  246.           (if (>= format:pos format-string-len)
  247.               (format:error "illegal format string")
  248.               (string-ref format-string format:pos))))
  249.            
  250.            (one-positive-integer?
  251.         (lambda (params)
  252.           (cond
  253.            ((null? params) #f)
  254.            ((and (integer? (car params))
  255.              (>= (car params) 0)
  256.              (= (length params) 1)) #t)
  257.            (else
  258.             (format:error
  259.              "one positive integer parameter expected")))))
  260.            
  261.            (next-arg
  262.         (lambda ()
  263.           (if (>= arg-pos arg-len)
  264.               (begin
  265.             (set! format:arg-pos (+ arg-len 1))
  266.             (format:error "missing argument(s)")))
  267.           (add-arg-pos 1)
  268.           (list-ref arglist (- arg-pos 1))))
  269.            
  270.            (prev-arg
  271.         (lambda ()
  272.           (add-arg-pos -1)
  273.           (if (negative? arg-pos)
  274.               (format:error "missing backward argument(s)"))
  275.           (list-ref arglist arg-pos)))
  276.            
  277.            (rest-args
  278.         (lambda ()
  279.           (let loop ((l arglist) (k arg-pos)) ; list-tail definition
  280.             (if (= k 0) l (loop (cdr l) (- k 1))))))
  281.            
  282.            (add-arg-pos
  283.         (lambda (n) 
  284.           (set! arg-pos (+ n arg-pos))
  285.           (set! format:arg-pos arg-pos)))
  286.            
  287.            (anychar-dispatch        ; dispatches the format-string
  288.         (lambda ()
  289.           (if (>= format:pos format-string-len)
  290.               arg-pos            ; used for ~? continuance
  291.               (let ((char (next-char)))
  292.             (cond
  293.              ((char=? char #\~)
  294.               (set! modifier #f)
  295.               (set! params '())
  296.               (set! param-value-found #f)
  297.               (tilde-dispatch))
  298.              (else
  299.               (if (and (zero? conditional-nest)
  300.                    (zero? iteration-nest))
  301.                   (format:out-char char))
  302.               (anychar-dispatch)))))))
  303.            
  304.            (tilde-dispatch
  305.         (lambda ()
  306.           (cond
  307.            ((>= format:pos format-string-len)
  308.             (format:out-str "~")    ; tilde at end of
  309.                     ; string is just
  310.                     ; output
  311.             arg-pos)            ; used for ~?
  312.                     ; continuance
  313.            ((and (or (zero? conditional-nest)
  314.                  (memv (peek-next-char) ; find conditional
  315.                     ; directives
  316.                    (append '(#\[ #\] #\; #\: #\@ #\^)
  317.                        format:parameter-characters)))
  318.              (or (zero? iteration-nest)
  319.                  (memv (peek-next-char) ; find iteration
  320.                     ; directives
  321.                    (append '(#\{ #\} #\: #\@ #\^)
  322.                        format:parameter-characters))))
  323.             (case (char-upcase (next-char))
  324.               
  325.               ;; format directives
  326.               
  327.               ((#\A)            ; Any -- for humans
  328.                (set! format:read-proof
  329.                  (memq modifier '(colon colon-at)))
  330.                (format:out-obj-padded (memq modifier '(at colon-at))
  331.                           (next-arg) #f params)
  332.                (anychar-dispatch))
  333.               ((#\S)            ; Slashified -- for parsers
  334.                (set! format:read-proof
  335.                  (memq modifier '(colon colon-at)))
  336.                (format:out-obj-padded (memq modifier '(at colon-at))
  337.                           (next-arg) #t params)
  338.                (anychar-dispatch))
  339.               ((#\D)            ; Decimal
  340.                (format:out-num-padded modifier (next-arg) params 10)
  341.                (anychar-dispatch))
  342.               ((#\X)            ; Hexadecimal
  343.                (format:out-num-padded modifier (next-arg) params 16)
  344.                (anychar-dispatch))
  345.               ((#\O)            ; Octal
  346.                (format:out-num-padded modifier (next-arg) params 8)
  347.                (anychar-dispatch))
  348.               ((#\B)            ; Binary
  349.                (format:out-num-padded modifier (next-arg) params 2)
  350.                (anychar-dispatch))
  351.               ((#\R)
  352.                (if (null? params)
  353.                (format:out-obj-padded ; Roman, cardinal,
  354.                     ; ordinal numerals
  355.                 #f
  356.                 ((case modifier
  357.                    ((at) format:num->roman)
  358.                    ((colon-at) format:num->old-roman)
  359.                    ((colon) format:num->ordinal)
  360.                    (else format:num->cardinal))
  361.                  (next-arg))
  362.                 #f params)
  363.                (format:out-num-padded ; any Radix
  364.                 modifier (next-arg) (cdr params) (car params)))
  365.                (anychar-dispatch))
  366.               ((#\F)            ; Fixed-format floating-point
  367.                (if format:floats
  368.                (format:out-fixed modifier (next-arg) params)
  369.                (format:out-str (number->string (next-arg))))
  370.                (anychar-dispatch))
  371.               ((#\E)            ; Exponential floating-point
  372.                (if format:floats
  373.                (format:out-expon modifier (next-arg) params)
  374.                (format:out-str (number->string (next-arg))))
  375.                (anychar-dispatch))
  376.               ((#\G)            ; General floating-point
  377.                (if format:floats
  378.                (format:out-general modifier (next-arg) params)
  379.                (format:out-str (number->string (next-arg))))
  380.                (anychar-dispatch))
  381.               ((#\$)            ; Dollars floating-point
  382.                (if format:floats
  383.                (format:out-dollar modifier (next-arg) params)
  384.                (format:out-str (number->string (next-arg))))
  385.                (anychar-dispatch))
  386.               ((#\I)            ; Complex numbers
  387.                (if (not format:complex-numbers)
  388.                (format:error
  389.                 "complex numbers not supported by this scheme system"))
  390.                (let ((z (next-arg)))
  391.              (if (not (complex? z))
  392.                  (format:error "argument not a complex number"))
  393.              (format:out-fixed modifier (real-part z) params)
  394.              (format:out-fixed 'at (imag-part z) params)
  395.              (format:out-char #\i))
  396.                (anychar-dispatch))
  397.               ((#\C)            ; Character
  398.                (let ((ch (if (one-positive-integer? params)
  399.                      (integer->char (car params))
  400.                      (next-arg))))
  401.              (if (not (char? ch))
  402.                  (format:error "~~c expects a character"))
  403.              (case modifier
  404.                ((at)
  405.                 (format:out-str (format:char->str ch)))
  406.                ((colon)
  407.                 (let ((c (char->integer ch)))
  408.                   (if (< c 0)
  409.                   (set! c (+ c 256))) ; compensate
  410.                     ; complement
  411.                     ; impl.
  412.                   (cond
  413.                    ((< c #x20)    ; assumes that control
  414.                     ; chars are < #x20
  415.                 (format:out-char #\^)
  416.                 (format:out-char
  417.                  (integer->char (+ c #x40))))
  418.                    ((>= c #x7f)
  419.                 (format:out-str "#\\")
  420.                 (format:out-str
  421.                  (if format:radix-pref
  422.                      (let ((s (number->string c 8)))
  423.                        (substring s 2 (string-length s)))
  424.                      (number->string c 8))))
  425.                    (else
  426.                 (format:out-char ch)))))
  427.                (else (format:out-char ch))))
  428.                (anychar-dispatch))
  429.               ((#\P)            ; Plural
  430.                (if (memq modifier '(colon colon-at))
  431.                (prev-arg))
  432.                (let ((arg (next-arg)))
  433.              (if (not (number? arg))
  434.                  (format:error "~~p expects a number argument"))
  435.              (if (= arg 1)
  436.                  (if (memq modifier '(at colon-at))
  437.                  (format:out-char #\y))
  438.                  (if (memq modifier '(at colon-at))
  439.                  (format:out-str "ies")
  440.                  (format:out-char #\s))))
  441.                (anychar-dispatch))
  442.               ((#\~)            ; Tilde
  443.                (if (one-positive-integer? params)
  444.                (format:out-fill (car params) #\~)
  445.                (format:out-char #\~))
  446.                (anychar-dispatch))
  447.               ((#\%)            ; Newline
  448.                (if (one-positive-integer? params)
  449.                (format:out-fill (car params) #\newline)
  450.                (format:out-char #\newline))
  451.                (set! format:output-col 0)
  452.                (anychar-dispatch))
  453.               ((#\&)            ; Fresh line
  454.                (if (one-positive-integer? params)
  455.                (begin
  456.                  (if (> (car params) 0)
  457.                  (format:out-fill (- (car params)
  458.                              (if (>
  459.                               format:output-col
  460.                               0) 0 1))
  461.                           #\newline))
  462.                  (set! format:output-col 0))
  463.                (if (> format:output-col 0)
  464.                    (format:out-char #\newline)))
  465.                (anychar-dispatch))
  466.               ((#\_)            ; Space character
  467.                (if (one-positive-integer? params)
  468.                (format:out-fill (car params) #\space)
  469.                (format:out-char #\space))
  470.                (anychar-dispatch))
  471.               ((#\/)            ; Tabulator character
  472.                (if (one-positive-integer? params)
  473.                (format:out-fill (car params) #\tab)
  474.                (format:out-char #\tab))
  475.                (anychar-dispatch))
  476.               ((#\|)            ; Page seperator
  477.                (if (one-positive-integer? params)
  478.                (format:out-fill (car params) #\page)
  479.                (format:out-char #\page))
  480.                (set! format:output-col 0)
  481.                (anychar-dispatch))
  482.               ((#\T)            ; Tabulate
  483.                (format:tabulate modifier params)
  484.                (anychar-dispatch))
  485.               ((#\Y)            ; Pretty-print
  486.                (pretty-print (next-arg) format:port)
  487.                (set! format:output-col 0)
  488.                (anychar-dispatch))
  489.               ((#\? #\K)        ; Indirection (is "~K" in T-Scheme)
  490.                (cond
  491.             ((memq modifier '(colon colon-at))
  492.              (format:error "illegal modifier in ~~?"))
  493.             ((eq? modifier 'at)
  494.              (let* ((frmt (next-arg))
  495.                 (args (rest-args)))
  496.                (add-arg-pos (format:format-work frmt args))))
  497.             (else
  498.              (let* ((frmt (next-arg))
  499.                 (args (next-arg)))
  500.                (format:format-work frmt args))))
  501.                (anychar-dispatch))
  502.               ((#\!)            ; Flush output
  503.                (set! format:flush-output #t)
  504.                (anychar-dispatch))
  505.               ((#\newline)        ; Continuation lines
  506.                (if (eq? modifier 'at)
  507.                (format:out-char #\newline))
  508.                (if (< format:pos format-string-len)
  509.                (do ((ch (peek-next-char) (peek-next-char)))
  510.                    ((or (not (char-whitespace? ch))
  511.                     (= format:pos (- format-string-len 1))))
  512.                  (if (eq? modifier 'colon)
  513.                  (format:out-char (next-char))
  514.                  (next-char))))
  515.                (anychar-dispatch))
  516.               ((#\*)            ; Argument jumping
  517.                (case modifier
  518.              ((colon)        ; jump backwards
  519.               (if (one-positive-integer? params)
  520.                   (do ((i 0 (+ i 1)))
  521.                   ((= i (car params)))
  522.                 (prev-arg))
  523.                   (prev-arg)))
  524.              ((at)            ; jump absolute
  525.               (set! arg-pos (if (one-positive-integer? params)
  526.                         (car params) 0)))
  527.              ((colon-at)
  528.               (format:error "illegal modifier `:@' in ~~* directive"))
  529.              (else            ; jump forward
  530.               (if (one-positive-integer? params)
  531.                   (do ((i 0 (+ i 1)))
  532.                   ((= i (car params)))
  533.                 (next-arg))
  534.                   (next-arg))))
  535.                (anychar-dispatch))
  536.               ((#\()            ; Case conversion begin
  537.                (set! format:case-conversion
  538.                  (case modifier
  539.                    ((at) string-capitalize-first)
  540.                    ((colon) string-capitalize)
  541.                    ((colon-at) string-upcase)
  542.                    (else string-downcase)))
  543.                (anychar-dispatch))
  544.               ((#\))            ; Case conversion end
  545.                (if (not format:case-conversion)
  546.                (format:error "missing ~~("))
  547.                (set! format:case-conversion #f)
  548.                (anychar-dispatch))
  549.               ((#\[)            ; Conditional begin
  550.                (set! conditional-nest (+ conditional-nest 1))
  551.                (cond
  552.             ((= conditional-nest 1)
  553.              (set! clause-pos format:pos)
  554.              (set! clause-default #f)
  555.              (set! clauses '())
  556.              (set! conditional-type
  557.                    (case modifier
  558.                  ((at) 'if-then)
  559.                  ((colon) 'if-else-then)
  560.                  ((colon-at) (format:error "illegal modifier in ~~["))
  561.                  (else 'num-case)))
  562.              (set! conditional-arg
  563.                    (if (one-positive-integer? params)
  564.                    (car params)
  565.                    (next-arg)))))
  566.                (anychar-dispatch))
  567.               ((#\;)                    ; Conditional separator
  568.                (if (zero? conditional-nest)
  569.                (format:error "~~; not in ~~[~~] conditional"))
  570.                (if (not (null? params))
  571.                (format:error "no parameter allowed in ~~;"))
  572.                (if (= conditional-nest 1)
  573.                (let ((clause-str
  574.                   (cond
  575.                    ((eq? modifier 'colon)
  576.                     (set! clause-default #t)
  577.                     (substring format-string clause-pos 
  578.                            (- format:pos 3)))
  579.                    ((memq modifier '(at colon-at))
  580.                     (format:error "illegal modifier in ~~;"))
  581.                    (else
  582.                     (substring format-string clause-pos
  583.                            (- format:pos 2))))))
  584.                  (set! clauses (append clauses (list clause-str)))
  585.                  (set! clause-pos format:pos)))
  586.                (anychar-dispatch))
  587.               ((#\])            ; Conditional end
  588.                (if (zero? conditional-nest) (format:error "missing ~~["))
  589.                (set! conditional-nest (- conditional-nest 1))
  590.                (if modifier
  591.                (format:error "no modifier allowed in ~~]"))
  592.                (if (not (null? params))
  593.                (format:error "no parameter allowed in ~~]"))
  594.                (cond
  595.             ((zero? conditional-nest)
  596.              (let ((clause-str (substring format-string clause-pos
  597.                               (- format:pos 2))))
  598.                (if clause-default
  599.                    (set! clause-default clause-str)
  600.                    (set! clauses (append clauses (list clause-str)))))
  601.              (case conditional-type
  602.                ((if-then)
  603.                 (if conditional-arg
  604.                 (format:format-work (car clauses)
  605.                             (list conditional-arg))))
  606.                ((if-else-then)
  607.                 (add-arg-pos
  608.                  (format:format-work (if conditional-arg
  609.                              (cadr clauses)
  610.                              (car clauses))
  611.                          (rest-args))))
  612.                ((num-case)
  613.                 (if (or (not (integer? conditional-arg))
  614.                     (< conditional-arg 0))
  615.                 (format:error "argument not a positive integer"))
  616.                 (if (not (and (>= conditional-arg (length clauses))
  617.                       (not clause-default)))
  618.                 (add-arg-pos
  619.                  (format:format-work
  620.                   (if (>= conditional-arg (length clauses))
  621.                       clause-default
  622.                       (list-ref clauses conditional-arg))
  623.                   (rest-args))))))))
  624.                (anychar-dispatch))
  625.               ((#\{)            ; Iteration begin
  626.                (set! iteration-nest (+ iteration-nest 1))
  627.                (cond
  628.             ((= iteration-nest 1)
  629.              (set! iteration-pos format:pos)
  630.              (set! iteration-type
  631.                    (case modifier
  632.                  ((at) 'rest-args)
  633.                  ((colon) 'sublists)
  634.                  ((colon-at) 'rest-sublists)
  635.                  (else 'list)))
  636.              (set! max-iterations (if (one-positive-integer? params)
  637.                           (car params) #f))))
  638.                (anychar-dispatch))
  639.               ((#\})            ; Iteration end
  640.                (if (zero? iteration-nest) (format:error "missing ~~{"))
  641.                (set! iteration-nest (- iteration-nest 1))
  642.                (case modifier
  643.              ((colon)
  644.               (if (not max-iterations) (set! max-iterations 1)))
  645.              ((colon-at at) (format:error "illegal modifier")))
  646.                (if (not (null? params))
  647.                (format:error "no parameters allowed in ~~}"))
  648.                (if (zero? iteration-nest)
  649.                (let ((iteration-str
  650.                   (substring format-string iteration-pos
  651.                          (- format:pos (if modifier 3 2)))))
  652.                  (if (string=? iteration-str "")
  653.                  (set! iteration-str (next-arg)))
  654.                  (case iteration-type
  655.                    ((list)
  656.                 (let ((args (next-arg))
  657.                       (args-len 0))
  658.                   (if (not (list? args))
  659.                       (format:error "expected a list argument"))
  660.                   (set! args-len (length args))
  661.                   (do ((arg-pos 0 (+ arg-pos
  662.                              (format:format-work
  663.                               iteration-str
  664.                               (list-tail args arg-pos))))
  665.                        (i 0 (+ i 1)))
  666.                       ((or (>= arg-pos args-len)
  667.                        (and max-iterations
  668.                         (>= i max-iterations)))))))
  669.                    ((sublists)
  670.                 (let ((args (next-arg))
  671.                       (args-len 0))
  672.                   (if (not (list? args))
  673.                       (format:error "expected a list argument"))
  674.                   (set! args-len (length args))
  675.                   (do ((arg-pos 0 (+ arg-pos 1)))
  676.                       ((or (>= arg-pos args-len)
  677.                        (and max-iterations
  678.                         (>= arg-pos max-iterations))))
  679.                     (let ((sublist (list-ref args arg-pos)))
  680.                       (if (not (list? sublist))
  681.                       (format:error
  682.                        "expected a list of lists argument"))
  683.                       (format:format-work iteration-str sublist)))))
  684.                    ((rest-args)
  685.                 (let* ((args (rest-args))
  686.                        (args-len (length args))
  687.                        (usedup-args
  688.                     (do ((arg-pos 0 (+ arg-pos
  689.                                (format:format-work
  690.                                 iteration-str
  691.                                 (list-tail
  692.                                  args arg-pos))))
  693.                          (i 0 (+ i 1)))
  694.                         ((or (>= arg-pos args-len)
  695.                          (and max-iterations
  696.                               (>= i max-iterations)))
  697.                          arg-pos))))
  698.                   (add-arg-pos usedup-args)))
  699.                    ((rest-sublists)
  700.                 (let* ((args (rest-args))
  701.                        (args-len (length args))
  702.                        (usedup-args
  703.                     (do ((arg-pos 0 (+ arg-pos 1)))
  704.                         ((or (>= arg-pos args-len)
  705.                          (and max-iterations
  706.                               (>= arg-pos max-iterations)))
  707.                          arg-pos)
  708.                       (let ((sublist (list-ref args arg-pos)))
  709.                         (if (not (list? sublist))
  710.                         (format:error "expected list arguments"))
  711.                         (format:format-work iteration-str sublist)))))
  712.                   (add-arg-pos usedup-args)))
  713.                    (else (format:error "internal error in ~~}")))))
  714.                (anychar-dispatch))
  715.               ((#\^)            ; Up and out
  716.                (let* ((continue
  717.                    (cond
  718.                 ((not (null? params))
  719.                  (not
  720.                   (case (length params)
  721.                     ((1) (zero? (car params)))
  722.                     ((2) (= (list-ref params 0) (list-ref params 1)))
  723.                     ((3) (<= (list-ref params 0)
  724.                          (list-ref params 1)
  725.                          (list-ref params 2)))
  726.                     (else (format:error "too much parameters")))))
  727.                 (format:case-conversion ; if conversion stop conversion
  728.                  (set! format:case-conversion string-copy) #t)
  729.                 ((= iteration-nest 1) #t)
  730.                 ((= conditional-nest 1) #t)
  731.                 ((>= arg-pos arg-len)
  732.                  (set! format:pos format-string-len) #f)
  733.                 (else #t))))
  734.              (if continue
  735.                  (anychar-dispatch))))
  736.  
  737.               ;; format directive modifiers and parameters
  738.  
  739.               ((#\@)            ; `@' modifier
  740.                (if (memq modifier '(at colon-at))
  741.                (format:error "double `@' modifier"))
  742.                (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
  743.                (tilde-dispatch))
  744.               ((#\:)            ; `:' modifier
  745.                (if (memq modifier '(colon colon-at))
  746.                (format:error "double `:' modifier"))
  747.                (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
  748.                (tilde-dispatch))
  749.               ((#\')            ; Character parameter
  750.                (if modifier (format:error "misplaced modifier"))
  751.                (set! params (append params (list (char->integer (next-char)))))
  752.                (set! param-value-found #t)
  753.                (tilde-dispatch))
  754.               ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
  755.                (if modifier (format:error "misplaced modifier"))
  756.                (let ((num-str-beg (- format:pos 1))
  757.                  (num-str-end format:pos))
  758.              (do ((ch (peek-next-char) (peek-next-char)))
  759.                  ((not (char-numeric? ch)))
  760.                (next-char)
  761.                (set! num-str-end (+ 1 num-str-end)))
  762.              (set! params
  763.                    (append params
  764.                        (list (string->number
  765.                           (substring format-string
  766.                              num-str-beg
  767.                              num-str-end))))))
  768.                (set! param-value-found #t)
  769.                (tilde-dispatch))
  770.               ((#\V)            ; Variable parameter from next argum.
  771.                (if modifier (format:error "misplaced modifier"))
  772.                (set! params (append params (list (next-arg))))
  773.                (set! param-value-found #t)
  774.                (tilde-dispatch))
  775.               ((#\#)            ; Parameter is number of remaining args
  776.                (if param-value-found (format:error "misplaced '#'"))
  777.                (if modifier (format:error "misplaced modifier"))
  778.                (set! params (append params (list (length (rest-args)))))
  779.                (set! param-value-found #t)
  780.                (tilde-dispatch))
  781.               ((#\,)            ; Parameter separators
  782.                (if modifier (format:error "misplaced modifier"))
  783.                (if (not param-value-found)
  784.                (set! params (append params '(#f)))) ; append empty paramtr
  785.                (set! param-value-found #f)
  786.                (tilde-dispatch))
  787.               ((#\Q)            ; Inquiry messages
  788.                (if (eq? modifier 'colon)
  789.                (format:out-str format:version)
  790.                (let ((nl (string #\newline)))
  791.                  (format:out-str
  792.                   (string-append
  793.                    "SLIB Common LISP format version " format:version nl
  794.                    "  (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
  795.                    "  please send bug reports to `lutzeb@cs.tu-berlin.de'"
  796.                    nl))))
  797.                (anychar-dispatch))
  798.               (else            ; Unknown tilde directive
  799.                (format:error "unknown control character `~c'"
  800.                      (string-ref format-string (- format:pos 1))))))
  801.            (else (anychar-dispatch)))))) ; in case of conditional
  802.  
  803.         (set! format:pos 0)
  804.         (set! format:arg-pos 0)
  805.         (anychar-dispatch)            ; start the formatting
  806.         (set! format:pos recursive-pos-save)
  807.         arg-pos)))                ; return the position in the arg. list
  808.  
  809.        ;; when format:read-proof is true, format:obj->str will wrap
  810.        ;; result strings starting with "#<" in an extra pair of double
  811.        ;; quotes.
  812.        
  813.        (format:read-proof #f)
  814.  
  815.        ;; format:obj->str returns a R4RS representation as a string of
  816.        ;; an arbitrary scheme object.
  817.  
  818.        (format:obj->str
  819.     (lambda (obj slashify)
  820.       (let ((res (if slashify
  821.              (object->string obj)
  822.              (with-output-to-string (lambda () (display obj))))))
  823.         (if (and format:read-proof (string-prefix? "#<" res))
  824.         (object->string res)
  825.         res))))
  826.  
  827.        ;; format:char->str converts a character into a slashified string as
  828.        ;; done by `write'. The procedure is dependent on the integer
  829.        ;; representation of characters and assumes a character number according to
  830.        ;; the ASCII character set.
  831.  
  832.        (format:char->str
  833.     (lambda (ch)
  834.       (let ((int-rep (char->integer ch)))
  835.         (if (< int-rep 0)            ; if chars are [-128...+127]
  836.         (set! int-rep (+ int-rep 256)))
  837.         (string-append
  838.          "#\\"
  839.          (cond
  840.           ((char=? ch #\newline) "newline")
  841.           ((and (>= int-rep 0) (<= int-rep 32))
  842.            (vector-ref format:ascii-non-printable-charnames int-rep))
  843.           ((= int-rep 127) "del")
  844.           ((>= int-rep 128)        ; octal representation
  845.            (if format:radix-pref
  846.            (let ((s (number->string int-rep 8)))
  847.              (substring s 2 (string-length s)))
  848.            (number->string int-rep 8)))
  849.           (else (string ch)))))))
  850.  
  851.        (format:space-ch (char->integer #\space))
  852.        (format:zero-ch (char->integer #\0))
  853.  
  854.        (format:par
  855.     (lambda (pars length index default name)
  856.       (if (> length index)
  857.           (let ((par (list-ref pars index)))
  858.         (if par
  859.             (if name
  860.             (if (< par 0)
  861.                 (format:error 
  862.                  "~s parameter must be a positive integer" name)
  863.                 par)
  864.             par)
  865.             default))
  866.           default)))
  867.  
  868.        (format:out-obj-padded
  869.     (lambda (pad-left obj slashify pars)
  870.            (if (null? pars)
  871.            (format:out-str (format:obj->str obj slashify))
  872.            (let ((l (length pars)))
  873.              (let ((mincol (format:par pars l 0 0 "mincol"))
  874.                (colinc (format:par pars l 1 1 "colinc"))
  875.                (minpad (format:par pars l 2 0 "minpad"))
  876.                (padchar (integer->char
  877.                      (format:par pars l 3 format:space-ch #f)))
  878.                (objstr (format:obj->str obj slashify)))
  879.                (if (not pad-left)
  880.                (format:out-str objstr))
  881.                (do ((objstr-len (string-length objstr))
  882.                 (i minpad (+ i colinc)))
  883.                ((>= (+ objstr-len i) mincol)
  884.                 (format:out-fill i padchar)))
  885.                (if pad-left
  886.                (format:out-str objstr)))))))
  887.  
  888.        (format:out-num-padded
  889.     (lambda (modifier number pars radix)
  890.       (if (not (integer? number)) (format:error "argument not an integer"))
  891.       (let ((numstr (number->string number radix)))
  892.         (if (and format:radix-pref (not (= radix 10)))
  893.         (set! numstr (substring numstr 2 (string-length numstr))))
  894.         (if (and (null? pars) (not modifier))
  895.         (format:out-str numstr)
  896.         (let ((l (length pars))
  897.               (numstr-len (string-length numstr)))
  898.           (let ((mincol (format:par pars l 0 #f "mincol"))
  899.             (padchar (integer->char
  900.                   (format:par pars l 1 format:space-ch #f)))
  901.             (commachar (integer->char
  902.                     (format:par pars l 2 (char->integer #\,) #f)))
  903.             (commawidth (format:par pars l 3 3 "commawidth")))
  904.             (if mincol
  905.             (let ((numlen numstr-len)) ; calc. the output len of number
  906.               (if (and (memq modifier '(at colon-at)) (>= number 0))
  907.                   (set! numlen (+ numlen 1)))
  908.               (if (memq modifier '(colon colon-at))
  909.                   (set! numlen (+ (quotient (- numstr-len 
  910.                                (if (< number 0) 2 1))
  911.                             commawidth)
  912.                           numlen)))
  913.               (if (> mincol numlen)
  914.                   (format:out-fill (- mincol numlen) padchar))))
  915.             (if (and (memq modifier '(at colon-at))
  916.                  (>= number 0))
  917.             (format:out-char #\+))
  918.             (if (memq modifier '(colon colon-at)) ; insert comma character
  919.             (let ((start (remainder numstr-len commawidth))
  920.                   (ns (if (< number 0) 1 0)))
  921.               (format:out-substr numstr 0 start)
  922.               (do ((i start (+ i commawidth)))
  923.                   ((>= i numstr-len))
  924.                 (if (> i ns)
  925.                 (format:out-char commachar))
  926.                 (format:out-substr numstr i (+ i commawidth))))
  927.             (format:out-str numstr))))))))
  928.  
  929.        (format:tabulate
  930.     (lambda (modifier pars)
  931.       (let ((l (length pars)))
  932.         (let ((colnum (format:par pars l 0 1 "colnum"))
  933.           (colinc (format:par pars l 1 1 "colinc"))
  934.           (padch (integer->char (format:par pars l 2 format:space-ch #f))))
  935.           (case modifier
  936.         ((colon colon-at)
  937.          (format:error "unsupported modifier for ~~t"))
  938.         ((at)                ; relative tabulation
  939.          (format:out-fill
  940.           (if (= colinc 0)
  941.               colnum            ; colnum = colrel
  942.               (do ((c 0 (+ c colinc))
  943.                (col (+ format:output-col colnum)))
  944.               ((>= c col)
  945.                (- c format:output-col))))
  946.           padch))
  947.         (else                ; absolute tabulation
  948.          (format:out-fill
  949.           (cond
  950.            ((< format:output-col colnum)
  951.             (- colnum format:output-col))
  952.            ((= colinc 0)
  953.             0)
  954.            (else
  955.             (do ((c colnum (+ c colinc)))
  956.             ((>= c format:output-col)
  957.              (- c format:output-col)))))
  958.           padch)))))))
  959.  
  960.  
  961.        ;; roman numerals (from dorai@cs.rice.edu).
  962.  
  963.        (format:roman-alist
  964.     '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
  965.       (10 #\X) (5 #\V) (1 #\I)))
  966.  
  967.        (format:roman-boundary-values
  968.     '(100 100 10 10 1 1 #f))
  969.  
  970.        (format:num->old-roman
  971.     (lambda (n)
  972.       (if (and (integer? n) (>= n 1))
  973.           (let loop ((n n)
  974.              (romans format:roman-alist)
  975.              (s '()))
  976.         (if (null? romans) (list->string (reverse s))
  977.             (let ((roman-val (caar romans))
  978.               (roman-dgt (cadar romans)))
  979.               (do ((q (quotient n roman-val) (- q 1))
  980.                (s s (cons roman-dgt s)))
  981.               ((= q 0)
  982.                (loop (remainder n roman-val)
  983.                  (cdr romans) s))))))
  984.           (format:error "only positive integers can be romanized"))))
  985.  
  986.        (format:num->roman
  987.     (lambda (n)
  988.       (if (and (integer? n) (> n 0))
  989.           (let loop ((n n)
  990.              (romans format:roman-alist)
  991.              (boundaries format:roman-boundary-values)
  992.              (s '()))
  993.         (if (null? romans)
  994.             (list->string (reverse s))
  995.             (let ((roman-val (caar romans))
  996.               (roman-dgt (cadar romans))
  997.               (bdry (car boundaries)))
  998.               (let loop2 ((q (quotient n roman-val))
  999.                   (r (remainder n roman-val))
  1000.                   (s s))
  1001.             (if (= q 0)
  1002.                 (if (and bdry (>= r (- roman-val bdry)))
  1003.                 (loop (remainder r bdry) (cdr romans)
  1004.                       (cdr boundaries)
  1005.                       (cons roman-dgt
  1006.                         (append
  1007.                          (cdr (assv bdry romans))
  1008.                          s)))
  1009.                 (loop r (cdr romans) (cdr boundaries) s))
  1010.                 (loop2 (- q 1) r (cons roman-dgt s)))))))
  1011.           (format:error "only positive integers can be romanized"))))
  1012.  
  1013.        ;; cardinals & ordinals (from dorai@cs.rice.edu)
  1014.  
  1015.        (format:cardinal-ones-list
  1016.     '(#f "one" "two" "three" "four" "five"
  1017.          "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
  1018.          "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
  1019.          "nineteen"))
  1020.  
  1021.        (format:cardinal-tens-list
  1022.     '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
  1023.          "ninety"))
  1024.  
  1025.        (format:num->cardinal999
  1026.     (lambda (n)
  1027.                     ;this procedure is inspired by the Bruno Haible's CLisp
  1028.                     ;function format-small-cardinal, which converts numbers
  1029.                     ;in the range 1 to 999, and is used for converting each
  1030.                     ;thousand-block in a larger number
  1031.       (let* ((hundreds (quotient n 100))
  1032.          (tens+ones (remainder n 100))
  1033.          (tens (quotient tens+ones 10))
  1034.          (ones (remainder tens+ones 10)))
  1035.         (append
  1036.          (if (> hundreds 0)
  1037.          (append
  1038.           (string->list
  1039.            (list-ref format:cardinal-ones-list hundreds))
  1040.           (string->list" hundred")
  1041.           (if (> tens+ones 0) '(#\space) '()))
  1042.          '())
  1043.          (if (< tens+ones 20)
  1044.          (if (> tens+ones 0)
  1045.              (string->list
  1046.               (list-ref format:cardinal-ones-list tens+ones))
  1047.              '())
  1048.          (append
  1049.           (string->list
  1050.            (list-ref format:cardinal-tens-list tens))
  1051.           (if (> ones 0)
  1052.               (cons #\-
  1053.                 (string->list
  1054.                  (list-ref format:cardinal-ones-list ones)))
  1055.               '())))))))
  1056.  
  1057.        (format:cardinal-thousand-block-list
  1058.     '("" " thousand" " million" " billion" " trillion" " quadrillion"
  1059.       " quintillion" " sextillion" " septillion" " octillion" " nonillion"
  1060.       " decillion" " undecillion" " duodecillion" " tredecillion"
  1061.       " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
  1062.       " octodecillion" " novemdecillion" " vigintillion"))
  1063.  
  1064.        (format:num->cardinal
  1065.     (lambda (n)
  1066.       (cond ((not (integer? n))
  1067.          (format:error
  1068.           "only integers can be converted to English cardinals"))
  1069.         ((= n 0) "zero")
  1070.         ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
  1071.         (else
  1072.          (let ((power3-word-limit
  1073.             (length format:cardinal-thousand-block-list)))
  1074.            (let loop ((n n)
  1075.                   (power3 0)
  1076.                   (s '()))
  1077.              (if (= n 0)
  1078.              (list->string s)
  1079.              (let ((n-before-block (quotient n 1000))
  1080.                    (n-after-block (remainder n 1000)))
  1081.                (loop n-before-block
  1082.                  (+ power3 1)
  1083.                  (if (> n-after-block 0)
  1084.                      (append
  1085.                       (if (> n-before-block 0)
  1086.                       (string->list ", ") '())
  1087.                       (format:num->cardinal999 n-after-block)
  1088.                       (if (< power3 power3-word-limit)
  1089.                       (string->list
  1090.                        (list-ref
  1091.                         format:cardinal-thousand-block-list
  1092.                         power3))
  1093.                       (append
  1094.                        (string->list " times ten to the ")
  1095.                        (string->list
  1096.                         (format:num->ordinal
  1097.                          (* power3 3)))
  1098.                        (string->list " power")))
  1099.                       s)
  1100.                      s))))))))))
  1101.  
  1102.        (format:ordinal-ones-list
  1103.     '(#f "first" "second" "third" "fourth" "fifth"
  1104.          "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
  1105.          "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
  1106.          "eighteenth" "nineteenth"))
  1107.  
  1108.        (format:ordinal-tens-list
  1109.     '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
  1110.          "seventieth" "eightieth" "ninetieth"))
  1111.  
  1112.        (format:num->ordinal
  1113.     (lambda (n)
  1114.       (cond ((not (integer? n))
  1115.          (format:error
  1116.           "only integers can be converted to English ordinals"))
  1117.         ((= n 0) "zeroth")
  1118.         ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
  1119.         (else
  1120.          (let ((hundreds (quotient n 100))
  1121.                (tens+ones (remainder n 100)))
  1122.            (string-append
  1123.             (if (> hundreds 0)
  1124.             (string-append
  1125.              (format:num->cardinal (* hundreds 100))
  1126.              (if (= tens+ones 0) "th" " "))
  1127.             "")
  1128.             (if (= tens+ones 0) ""
  1129.             (if (< tens+ones 20)
  1130.                 (list-ref format:ordinal-ones-list tens+ones)
  1131.                 (let ((tens (quotient tens+ones 10))
  1132.                   (ones (remainder tens+ones 10)))
  1133.                   (if (= ones 0)
  1134.                   (list-ref format:ordinal-tens-list tens)
  1135.                   (string-append
  1136.                    (list-ref format:cardinal-tens-list tens)
  1137.                    "-"
  1138.                    (list-ref format:ordinal-ones-list ones))))
  1139.                 ))))))))
  1140.  
  1141.        ;; format inf and nan.
  1142.  
  1143.        (format:out-inf-nan
  1144.     (lambda (number width digits edigits overch padch)
  1145.       ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
  1146.       ;; "+nan.0", suitably justified in their field.  We insist on
  1147.       ;; printing this exact form so that the numbers can be read back in.
  1148.  
  1149.       (let* ((str (number->string number))
  1150.          (len (string-length str))
  1151.          (dot (string-index str #\.))
  1152.          (digits (+ (or digits 0)
  1153.                 (if edigits (+ edigits 2) 0))))
  1154.         (if (and width overch (< width len))
  1155.         (format:out-fill width (integer->char overch))
  1156.         (let* ((leftpad (if width
  1157.                     (max (- width (max len (+ dot 1 digits))) 0)
  1158.                     0))
  1159.                (rightpad (if width
  1160.                      (max (- width leftpad len) 0)
  1161.                      0))
  1162.                (padch (integer->char (or padch format:space-ch)))) 
  1163.           (format:out-fill leftpad padch)
  1164.           (format:out-str str)
  1165.           (format:out-fill rightpad padch))))))
  1166.  
  1167.        ;; format fixed flonums (~F)
  1168.  
  1169.        (format:out-fixed
  1170.     (lambda (modifier number pars)
  1171.       (if (not (or (number? number) (string? number)))
  1172.           (format:error "argument is not a number or a number string"))
  1173.  
  1174.       (let ((l (length pars)))
  1175.         (let ((width (format:par pars l 0 #f "width"))
  1176.           (digits (format:par pars l 1 #f "digits"))
  1177.           (scale (format:par pars l 2 0 #f))
  1178.           (overch (format:par pars l 3 #f #f))
  1179.           (padch (format:par pars l 4 format:space-ch #f)))
  1180.  
  1181.           (cond
  1182.            ((or (inf? number) (nan? number))
  1183.         (format:out-inf-nan number width digits #f overch padch))
  1184.  
  1185.            (digits
  1186.         (format:parse-float 
  1187.          (if (string? number) number (number->string number)) #t scale)
  1188.         (if (<= (- format:fn-len format:fn-dot) digits)
  1189.             (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
  1190.             (format:fn-round digits))
  1191.         (if width
  1192.             (let ((numlen (+ format:fn-len 1)))
  1193.               (if (or (not format:fn-pos?) (eq? modifier 'at))
  1194.               (set! numlen (+ numlen 1)))
  1195.               (if (and (= format:fn-dot 0) (> width (+ digits 1)))
  1196.               (set! numlen (+ numlen 1)))
  1197.               (if (< numlen width)
  1198.               (format:out-fill (- width numlen) (integer->char padch)))
  1199.               (if (and overch (> numlen width))
  1200.               (format:out-fill width (integer->char overch))
  1201.               (format:fn-out modifier (> width (+ digits 1)))))
  1202.             (format:fn-out modifier #t)))
  1203.  
  1204.            (else
  1205.         (format:parse-float
  1206.          (if (string? number) number (number->string number)) #t scale)
  1207.         (format:fn-strip)
  1208.         (if width
  1209.             (let ((numlen (+ format:fn-len 1)))
  1210.               (if (or (not format:fn-pos?) (eq? modifier 'at))
  1211.               (set! numlen (+ numlen 1)))
  1212.               (if (= format:fn-dot 0)
  1213.               (set! numlen (+ numlen 1)))
  1214.               (if (< numlen width)
  1215.               (format:out-fill (- width numlen) (integer->char padch)))
  1216.               (if (> numlen width)    ; adjust precision if possible
  1217.               (let ((dot-index (- numlen
  1218.                           (- format:fn-len format:fn-dot))))
  1219.                 (if (> dot-index width)
  1220.                 (if overch    ; numstr too big for required width
  1221.                     (format:out-fill width (integer->char overch))
  1222.                     (format:fn-out modifier #t))
  1223.                 (begin
  1224.                   (format:fn-round (- width dot-index))
  1225.                   (format:fn-out modifier #t))))
  1226.               (format:fn-out modifier #t)))
  1227.             (format:fn-out modifier #t))))))))
  1228.  
  1229.        ;; format exponential flonums (~E)
  1230.  
  1231.        (format:out-expon
  1232.     (lambda (modifier number pars)
  1233.       (if (not (or (number? number) (string? number)))
  1234.           (format:error "argument is not a number"))
  1235.  
  1236.       (let ((l (length pars)))
  1237.         (let ((width (format:par pars l 0 #f "width"))
  1238.           (digits (format:par pars l 1 #f "digits"))
  1239.           (edigits (format:par pars l 2 #f "exponent digits"))
  1240.           (scale (format:par pars l 3 1 #f))
  1241.           (overch (format:par pars l 4 #f #f))
  1242.           (padch (format:par pars l 5 format:space-ch #f))
  1243.           (expch (format:par pars l 6 #f #f)))
  1244.           
  1245.           (cond
  1246.            ((or (inf? number) (nan? number))
  1247.         (format:out-inf-nan number width digits edigits overch padch))
  1248.  
  1249.            (digits                ; fixed precision
  1250.  
  1251.         (let ((digits (if (> scale 0)
  1252.                   (if (< scale (+ digits 2))
  1253.                       (+ (- digits scale) 1)
  1254.                       0)
  1255.                   digits)))
  1256.           (format:parse-float 
  1257.            (if (string? number) number (number->string number)) #f scale)
  1258.           (if (<= (- format:fn-len format:fn-dot) digits)
  1259.               (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
  1260.               (format:fn-round digits))
  1261.           (if width
  1262.               (if (and edigits overch (> format:en-len edigits))
  1263.               (format:out-fill width (integer->char overch))
  1264.               (let ((numlen (+ format:fn-len 3))) ; .E+
  1265.                 (if (or (not format:fn-pos?) (eq? modifier 'at))
  1266.                 (set! numlen (+ numlen 1)))
  1267.                 (if (and (= format:fn-dot 0) (> width (+ digits 1)))
  1268.                 (set! numlen (+ numlen 1)))    
  1269.                 (set! numlen
  1270.                   (+ numlen 
  1271.                      (if (and edigits (>= edigits format:en-len))
  1272.                      edigits 
  1273.                      format:en-len)))
  1274.                 (if (< numlen width)
  1275.                 (format:out-fill (- width numlen)
  1276.                          (integer->char padch)))
  1277.                 (if (and overch (> numlen width))
  1278.                 (format:out-fill width (integer->char overch))
  1279.                 (begin
  1280.                   (format:fn-out modifier (> width (- numlen 1)))
  1281.                   (format:en-out edigits expch)))))
  1282.               (begin
  1283.             (format:fn-out modifier #t)
  1284.             (format:en-out edigits expch)))))
  1285.  
  1286.            (else
  1287.         (format:parse-float
  1288.          (if (string? number) number (number->string number)) #f scale)
  1289.         (format:fn-strip)
  1290.         (if width
  1291.             (if (and edigits overch (> format:en-len edigits))
  1292.             (format:out-fill width (integer->char overch))
  1293.             (let ((numlen (+ format:fn-len 3))) ; .E+
  1294.               (if (or (not format:fn-pos?) (eq? modifier 'at))
  1295.                   (set! numlen (+ numlen 1)))
  1296.               (if (= format:fn-dot 0)
  1297.                   (set! numlen (+ numlen 1)))
  1298.               (set! numlen
  1299.                 (+ numlen
  1300.                    (if (and edigits (>= edigits format:en-len))
  1301.                        edigits 
  1302.                        format:en-len)))
  1303.               (if (< numlen width)
  1304.                   (format:out-fill (- width numlen)
  1305.                            (integer->char padch)))
  1306.               (if (> numlen width) ; adjust precision if possible
  1307.                   (let ((f (- format:fn-len format:fn-dot))) ; fract len
  1308.                 (if (> (- numlen f) width)
  1309.                     (if overch ; numstr too big for required width
  1310.                     (format:out-fill width 
  1311.                              (integer->char overch))
  1312.                     (begin
  1313.                       (format:fn-out modifier #t)
  1314.                       (format:en-out edigits expch)))
  1315.                     (begin
  1316.                       (format:fn-round (+ (- f numlen) width))
  1317.                       (format:fn-out modifier #t)
  1318.                       (format:en-out edigits expch))))
  1319.                   (begin
  1320.                 (format:fn-out modifier #t)
  1321.                 (format:en-out edigits expch)))))
  1322.             (begin
  1323.               (format:fn-out modifier #t)
  1324.               (format:en-out edigits expch)))))))))
  1325.        
  1326.        ;; format general flonums (~G)
  1327.  
  1328.        (format:out-general
  1329.     (lambda (modifier number pars)
  1330.       (if (not (or (number? number) (string? number)))
  1331.           (format:error "argument is not a number or a number string"))
  1332.  
  1333.       (let ((l (length pars)))
  1334.         (let ((width (if (> l 0) (list-ref pars 0) #f))
  1335.           (digits (if (> l 1) (list-ref pars 1) #f))
  1336.           (edigits (if (> l 2) (list-ref pars 2) #f))
  1337.           (overch (if (> l 4) (list-ref pars 4) #f))
  1338.           (padch (if (> l 5) (list-ref pars 5) #f)))
  1339.           (cond
  1340.            ((or (inf? number) (nan? number))
  1341.         ;; FIXME: this isn't right.
  1342.         (format:out-inf-nan number width digits edigits overch padch))
  1343.            (else
  1344.         (format:parse-float
  1345.          (if (string? number) number (number->string number)) #t 0)
  1346.         (format:fn-strip)
  1347.         (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
  1348.                (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
  1349.                (n (if (= format:fn-dot 0)    ; number less than (abs 1.0) ?
  1350.                   (- (format:fn-zlead))
  1351.                   format:fn-dot))
  1352.                (d (if digits
  1353.                   digits
  1354.                   (max format:fn-len (min n 7)))) ; q = format:fn-len
  1355.                (dd (- d n)))
  1356.           (if (<= 0 dd d)
  1357.               (begin
  1358.             (format:out-fixed modifier number (list ww dd #f overch padch))
  1359.             (format:out-fill ee #\space)) ;~@T not implemented yet
  1360.               (format:out-expon modifier number pars)))))))))
  1361.  
  1362.        ;; format dollar flonums (~$)
  1363.  
  1364.        (format:out-dollar
  1365.     (lambda (modifier number pars)
  1366.       (if (not (or (number? number) (string? number)))
  1367.           (format:error "argument is not a number or a number string"))
  1368.  
  1369.       (let ((l (length pars)))
  1370.         (let ((digits (format:par pars l 0 2 "digits"))
  1371.           (mindig (format:par pars l 1 1 "mindig"))
  1372.           (width (format:par pars l 2 0 "width"))
  1373.           (padch (format:par pars l 3 format:space-ch #f)))
  1374.  
  1375.           (cond
  1376.            ((or (inf? number) (nan? number))
  1377.         (format:out-inf-nan number width digits #f #f padch))
  1378.  
  1379.            (else
  1380.         (format:parse-float
  1381.          (if (string? number) number (number->string number)) #t 0)
  1382.         (if (<= (- format:fn-len format:fn-dot) digits)
  1383.             (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
  1384.             (format:fn-round digits))
  1385.         (let ((numlen (+ format:fn-len 1)))
  1386.           (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
  1387.               (set! numlen (+ numlen 1)))
  1388.           (if (and mindig (> mindig format:fn-dot))
  1389.               (set! numlen (+ numlen (- mindig format:fn-dot))))
  1390.           (if (and (= format:fn-dot 0) (not mindig))
  1391.               (set! numlen (+ numlen 1)))
  1392.           (if (< numlen width)
  1393.               (case modifier
  1394.             ((colon)
  1395.              (if (not format:fn-pos?)
  1396.                  (format:out-char #\-))
  1397.              (format:out-fill (- width numlen) (integer->char padch)))
  1398.             ((at)
  1399.              (format:out-fill (- width numlen) (integer->char padch))
  1400.              (format:out-char (if format:fn-pos? #\+ #\-)))
  1401.             ((colon-at)
  1402.              (format:out-char (if format:fn-pos? #\+ #\-))
  1403.              (format:out-fill (- width numlen) (integer->char padch)))
  1404.             (else
  1405.              (format:out-fill (- width numlen) (integer->char padch))
  1406.              (if (not format:fn-pos?)
  1407.                  (format:out-char #\-))))
  1408.               (if format:fn-pos?
  1409.               (if (memq modifier '(at colon-at)) (format:out-char #\+))
  1410.               (format:out-char #\-))))
  1411.         (if (and mindig (> mindig format:fn-dot))
  1412.             (format:out-fill (- mindig format:fn-dot) #\0))
  1413.         (if (and (= format:fn-dot 0) (not mindig))
  1414.             (format:out-char #\0))
  1415.         (format:out-substr format:fn-str 0 format:fn-dot)
  1416.         (format:out-char #\.)
  1417.         (format:out-substr format:fn-str format:fn-dot format:fn-len)))))))
  1418.  
  1419.                     ; the flonum buffers
  1420.  
  1421.        (format:fn-max 400)        ; max. number of number digits
  1422.        (format:fn-str #f) ; number buffer
  1423.        (format:fn-len 0)        ; digit length of number
  1424.        (format:fn-dot #f)        ; dot position of number
  1425.        (format:fn-pos? #t)        ; number positive?
  1426.        (format:en-max 10)        ; max. number of exponent digits
  1427.        (format:en-str #f) ; exponent buffer
  1428.        (format:en-len 0)        ; digit length of exponent
  1429.        (format:en-pos? #t)        ; exponent positive?
  1430.  
  1431.        (format:parse-float
  1432.     (lambda (num-str fixed? scale)
  1433.          (set! format:fn-pos? #t)
  1434.          (set! format:fn-len 0)
  1435.          (set! format:fn-dot #f)
  1436.          (set! format:en-pos? #t)
  1437.          (set! format:en-len 0)
  1438.          (do ((i 0 (+ i 1))
  1439.               (left-zeros 0)
  1440.               (mantissa? #t)
  1441.               (all-zeros? #t)
  1442.               (num-len (string-length num-str))
  1443.               (c #f))            ; current exam. character in num-str
  1444.              ((= i num-len)
  1445.               (if (not format:fn-dot)
  1446.               (set! format:fn-dot format:fn-len))
  1447.  
  1448.               (if all-zeros?
  1449.               (begin
  1450.                 (set! left-zeros 0)
  1451.                 (set! format:fn-dot 0)
  1452.                 (set! format:fn-len 1)))
  1453.  
  1454.               ;; now format the parsed values according to format's need
  1455.  
  1456.               (if fixed?
  1457.  
  1458.               (begin            ; fixed format m.nnn or .nnn
  1459.                 (if (and (> left-zeros 0) (> format:fn-dot 0))
  1460.                 (if (> format:fn-dot left-zeros) 
  1461.                     (begin        ; norm 0{0}nn.mm to nn.mm
  1462.                       (format:fn-shiftleft left-zeros)
  1463.                       (set! format:fn-dot (- format:fn-dot left-zeros))
  1464.                       (set! left-zeros 0))
  1465.                     (begin        ; normalize 0{0}.nnn to .nnn
  1466.                       (format:fn-shiftleft format:fn-dot)
  1467.                       (set! left-zeros (- left-zeros format:fn-dot))
  1468.                       (set! format:fn-dot 0))))
  1469.                 (if (or (not (= scale 0)) (> format:en-len 0))
  1470.                 (let ((shift (+ scale (format:en-int))))
  1471.                   (cond
  1472.                    (all-zeros? #t)
  1473.                    ((> (+ format:fn-dot shift) format:fn-len)
  1474.                     (format:fn-zfill
  1475.                      #f (- shift (- format:fn-len format:fn-dot)))
  1476.                     (set! format:fn-dot format:fn-len))
  1477.                    ((< (+ format:fn-dot shift) 0)
  1478.                     (format:fn-zfill #t (- (- shift) format:fn-dot))
  1479.                     (set! format:fn-dot 0))
  1480.                    (else
  1481.                     (if (> left-zeros 0)
  1482.                     (if (<= left-zeros shift) ; shift always > 0 here
  1483.                         (format:fn-shiftleft shift) ; shift out 0s
  1484.                         (begin
  1485.                           (format:fn-shiftleft left-zeros)
  1486.                           (set! format:fn-dot (- shift left-zeros))))
  1487.                     (set! format:fn-dot (+ format:fn-dot shift))))))))
  1488.  
  1489.               (let ((negexp        ; expon format m.nnnEee
  1490.                  (if (> left-zeros 0)
  1491.                      (- left-zeros format:fn-dot -1)
  1492.                      (if (= format:fn-dot 0) 1 0))))
  1493.                 (if (> left-zeros 0)
  1494.                 (begin            ; normalize 0{0}.nnn to n.nn
  1495.                   (format:fn-shiftleft left-zeros)
  1496.                   (set! format:fn-dot 1))
  1497.                 (if (= format:fn-dot 0)
  1498.                     (set! format:fn-dot 1)))
  1499.                 (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
  1500.                           negexp))
  1501.                 (cond 
  1502.                  (all-zeros?
  1503.                   (format:en-set 0)
  1504.                   (set! format:fn-dot 1))
  1505.                  ((< scale 0)        ; leading zero
  1506.                   (format:fn-zfill #t (- scale))
  1507.                   (set! format:fn-dot 0))
  1508.                  ((> scale format:fn-dot)
  1509.                   (format:fn-zfill #f (- scale format:fn-dot))
  1510.                   (set! format:fn-dot scale))
  1511.                  (else
  1512.                   (set! format:fn-dot scale)))))
  1513.               #t)
  1514.  
  1515.            ;; do body      
  1516.            (set! c (string-ref num-str i))    ; parse the output of number->string
  1517.            (cond                ; which can be any valid number
  1518.             ((char-numeric? c)            ; representation of R4RS except 
  1519.              (if mantissa?            ; complex numbers
  1520.              (begin
  1521.                (if (char=? c #\0)
  1522.                    (if all-zeros?
  1523.                    (set! left-zeros (+ left-zeros 1)))
  1524.                    (begin
  1525.                  (set! all-zeros? #f)))
  1526.                (string-set! format:fn-str format:fn-len c)
  1527.                (set! format:fn-len (+ format:fn-len 1)))
  1528.              (begin
  1529.                (string-set! format:en-str format:en-len c)
  1530.                (set! format:en-len (+ format:en-len 1)))))
  1531.             ((or (char=? c #\-) (char=? c #\+))
  1532.              (if mantissa?
  1533.              (set! format:fn-pos? (char=? c #\+))
  1534.              (set! format:en-pos? (char=? c #\+))))
  1535.             ((char=? c #\.)
  1536.              (set! format:fn-dot format:fn-len))
  1537.             ((char=? c #\e)
  1538.              (set! mantissa? #f))
  1539.             ((char=? c #\E)
  1540.              (set! mantissa? #f))
  1541.             ((char-whitespace? c) #t)
  1542.             ((char=? c #\d) #t)        ; decimal radix prefix
  1543.             ((char=? c #\#) #t)
  1544.             (else
  1545.              (format:error "illegal character `~c' in number->string" c))))))
  1546.  
  1547.        (format:en-int
  1548.     (lambda ()            ; convert exponent string to integer
  1549.       (if (= format:en-len 0)
  1550.           0
  1551.           (do ((i 0 (+ i 1))
  1552.            (n 0))
  1553.           ((= i format:en-len) 
  1554.            (if format:en-pos?
  1555.                n
  1556.                (- n)))
  1557.         (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
  1558.                        format:zero-ch)))))))
  1559.  
  1560.        (format:en-set          ; set exponent string number
  1561.     (lambda (en)        
  1562.       (set! format:en-len 0)
  1563.       (set! format:en-pos? (>= en 0))
  1564.       (let ((en-str (number->string en)))
  1565.         (do ((i 0 (+ i 1))
  1566.          (en-len (string-length en-str))
  1567.          (c #f))
  1568.         ((= i en-len))
  1569.           (set! c (string-ref en-str i))
  1570.           (if (char-numeric? c)
  1571.           (begin
  1572.             (string-set! format:en-str format:en-len c)
  1573.             (set! format:en-len (+ format:en-len 1))))))))
  1574.  
  1575.        (format:fn-zfill    ; fill current number string with 0s
  1576.     (lambda (left? n)
  1577.       (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
  1578.           (format:error "number is too long to format (enlarge format:fn-max)"))
  1579.       (set! format:fn-len (+ format:fn-len n))
  1580.       (if left?
  1581.           (do ((i format:fn-len (- i 1)))    ; fill n 0s to left
  1582.           ((< i 0))
  1583.         (string-set! format:fn-str i
  1584.                  (if (< i n)
  1585.                  #\0
  1586.                  (string-ref format:fn-str (- i n)))))
  1587.           (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
  1588.           ((= i format:fn-len))
  1589.         (string-set! format:fn-str i #\0)))))
  1590.  
  1591.        (format:fn-shiftleft        ; shift left current number n positions
  1592.     (lambda (n)
  1593.       (if (> n format:fn-len)
  1594.           (format:error "internal error in format:fn-shiftleft (~d,~d)"
  1595.                 n format:fn-len))
  1596.       (do ((i n (+ i 1)))
  1597.           ((= i format:fn-len)
  1598.            (set! format:fn-len (- format:fn-len n)))
  1599.         (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))))
  1600.  
  1601.        (format:fn-round    ; round format:fn-str
  1602.     (lambda (digits)
  1603.       (set! digits (+ digits format:fn-dot))
  1604.       (do ((i digits (- i 1))        ; "099",2 -> "10"
  1605.            (c 5))                ; "023",2 -> "02"
  1606.           ((or (= c 0) (< i 0))        ; "999",2 -> "100"
  1607.            (if (= c 1)            ; "005",2 -> "01"
  1608.            (begin            ; carry overflow
  1609.              (set! format:fn-len digits)
  1610.              (format:fn-zfill #t 1)    ; add a 1 before fn-str
  1611.              (string-set! format:fn-str 0 #\1)
  1612.              (set! format:fn-dot (+ format:fn-dot 1)))
  1613.            (set! format:fn-len digits)))
  1614.         (set! c (+ (- (char->integer (string-ref format:fn-str i))
  1615.               format:zero-ch) c))
  1616.         (string-set! format:fn-str i (integer->char
  1617.                       (if (< c 10) 
  1618.                           (+ c format:zero-ch)
  1619.                           (+ (- c 10) format:zero-ch))))
  1620.         (set! c (if (< c 10) 0 1)))))
  1621.  
  1622.        (format:fn-out
  1623.     (lambda (modifier add-leading-zero?)
  1624.       (if format:fn-pos?
  1625.           (if (eq? modifier 'at) 
  1626.           (format:out-char #\+))
  1627.           (format:out-char #\-))
  1628.       (if (= format:fn-dot 0)
  1629.           (if add-leading-zero?
  1630.           (format:out-char #\0))
  1631.           (format:out-substr format:fn-str 0 format:fn-dot))
  1632.       (format:out-char #\.)
  1633.       (format:out-substr format:fn-str format:fn-dot format:fn-len)))
  1634.  
  1635.        (format:en-out
  1636.     (lambda (edigits expch)
  1637.       (format:out-char (if expch (integer->char expch) format:expch))
  1638.       (format:out-char (if format:en-pos? #\+ #\-))
  1639.       (if edigits 
  1640.           (if (< format:en-len edigits)
  1641.           (format:out-fill (- edigits format:en-len) #\0)))
  1642.       (format:out-substr format:en-str 0 format:en-len)))
  1643.  
  1644.        (format:fn-strip        ; strip trailing zeros but one
  1645.     (lambda ()
  1646.       (string-set! format:fn-str format:fn-len #\0)
  1647.       (do ((i format:fn-len (- i 1)))
  1648.           ((or (not (char=? (string-ref format:fn-str i) #\0))
  1649.            (<= i format:fn-dot))
  1650.            (set! format:fn-len (+ i 1))))))
  1651.  
  1652.        (format:fn-zlead        ; count leading zeros
  1653.     (lambda ()
  1654.       (do ((i 0 (+ i 1)))
  1655.           ((or (= i format:fn-len)
  1656.            (not (char=? (string-ref format:fn-str i) #\0)))
  1657.            (if (= i format:fn-len)        ; found a real zero
  1658.            0
  1659.            i)))))
  1660.  
  1661.  
  1662. ;;; some global functions not found in SLIB
  1663.  
  1664.        (string-capitalize-first    ; "hello" -> "Hello"
  1665.     (lambda (str)
  1666.       (let ((cap-str (string-copy str))    ; "hELLO" -> "Hello"
  1667.         (non-first-alpha #f)        ; "*hello" -> "*Hello"
  1668.         (str-len (string-length str)))    ; "hello you" -> "Hello you"
  1669.         (do ((i 0 (+ i 1)))
  1670.         ((= i str-len) cap-str)
  1671.           (let ((c (string-ref str i)))
  1672.         (if (char-alphabetic? c)
  1673.             (if non-first-alpha
  1674.             (string-set! cap-str i (char-downcase c))
  1675.             (begin
  1676.               (set! non-first-alpha #t)
  1677.               (string-set! cap-str i (char-upcase c))))))))))
  1678.  
  1679.        ;; Aborts the program when a formatting error occures. This is a null
  1680.        ;; argument closure to jump to the interpreters toplevel continuation.
  1681.  
  1682.        (format:abort (lambda () (error "error in format"))))
  1683.     
  1684.     (set! format:error-save format:error)
  1685.     (set! format:fn-str (make-string format:fn-max)) ; number buffer
  1686.     (set! format:en-str (make-string format:en-max)) ; exponent buffer
  1687.     (apply format:format args)))
  1688.  
  1689. ;; Thanks to Shuji Narazaki
  1690. (module-set! the-root-module 'format format)
  1691.