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