152 lines
4.1 KiB
Scheme
152 lines
4.1 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; Quicky FORMAT
|
|
;
|
|
; (FORMAT port string . args)
|
|
;
|
|
; PORT is one of:
|
|
; an output port, in which case FORMAT prints to the port;
|
|
; #T, FORMAT prints to the current output port;
|
|
; #F, FORMAT returns a string.
|
|
;
|
|
; The following format directives have been implemented:
|
|
; ~~ -prints a single ~
|
|
; ~A -prints the next argument using DISPLAY
|
|
; ~S -prints the next argument using WRITE
|
|
; ~% -prints a NEWLINE character
|
|
; ~& -prints a NEWLINE character if the previous printed character was not one
|
|
; (this is implemented using FRESH-LINE)
|
|
; ~? -performs a recursive call to FORMAT using the next two arguments as the
|
|
; string and the list of arguments
|
|
;
|
|
; FORMAT is case-insensitive with respect to letter directives (~a and ~A have
|
|
; the same effect).
|
|
|
|
; The entry point. Gets the port and writes the output.
|
|
; Get the appropriate writer for the port specification.
|
|
|
|
(define (format port string . args)
|
|
(cond ((not port)
|
|
(call-with-string-output-port
|
|
(lambda (port)
|
|
(real-format port string args))))
|
|
((eq? port #t)
|
|
(real-format (current-output-port) string args))
|
|
((output-port? port)
|
|
(real-format port string args))
|
|
(else
|
|
(error "invalid port argument to FORMAT" port))))
|
|
|
|
; Loop down the format string printing characters and dispatching on directives
|
|
; as required. Procedures for the directives are in a vector indexed by
|
|
; character codes. Each procedure takes four arguments: the format string,
|
|
; the index of the next unsed character in the format string, the list of
|
|
; remaining arguments, and the writer. Each should return a list of the unused
|
|
; arguments.
|
|
|
|
(define (real-format out string all-args)
|
|
(let loop ((i 0) (args all-args))
|
|
(cond ((>= i (string-length string))
|
|
(if (null? args)
|
|
#f
|
|
(error "too many arguments to FORMAT" string all-args)))
|
|
((char=? #\~ (string-ref string i))
|
|
(if (= (+ i 1) (string-length string))
|
|
(error "invalid format string" string i)
|
|
(loop (+ i 2)
|
|
((vector-ref format-dispatch-vector
|
|
(char->ascii (string-ref string (+ i 1))))
|
|
string
|
|
(+ i 2)
|
|
args
|
|
out))))
|
|
(else
|
|
(write-char (string-ref string i) out)
|
|
(loop (+ i 1) args)))))
|
|
|
|
; One more than the highest integer that CHAR->ASCII may return.
|
|
(define number-of-char-codes ascii-limit)
|
|
|
|
; The vector of procedures implementing format directives.
|
|
|
|
(define format-dispatch-vector
|
|
(make-vector number-of-char-codes
|
|
(lambda (string i args out)
|
|
(error "illegal format command"
|
|
string
|
|
(string-ref string (- i 1))))))
|
|
|
|
; This implements FORMATs case-insensitivity.
|
|
|
|
(define (define-format-command char proc)
|
|
(vector-set! format-dispatch-vector (char->ascii char) proc)
|
|
(if (char-alphabetic? char)
|
|
(vector-set! format-dispatch-vector
|
|
(char->ascii (if (char-lower-case? char)
|
|
(char-upcase char)
|
|
(char-downcase char)))
|
|
proc)))
|
|
|
|
; Write a single ~ character.
|
|
|
|
(define-format-command #\~
|
|
(lambda (string i args out)
|
|
(write-char #\~ out)
|
|
args))
|
|
|
|
; Newline
|
|
|
|
(define-format-command #\%
|
|
(lambda (string i args out)
|
|
(newline out)
|
|
args))
|
|
|
|
; Fresh-Line
|
|
|
|
(define-format-command #\&
|
|
(lambda (string i args out)
|
|
(fresh-line out)
|
|
args))
|
|
|
|
; Display (`A' is for ASCII)
|
|
|
|
(define-format-command #\a
|
|
(lambda (string i args out)
|
|
(check-for-format-arg args)
|
|
(display (car args) out)
|
|
(cdr args)))
|
|
|
|
; Decimals
|
|
|
|
(define-format-command #\d
|
|
(lambda (string i args out)
|
|
(check-for-format-arg args)
|
|
(display (number->string (car args) 10) out)
|
|
(cdr args)))
|
|
|
|
; Write (`S' is for S-expression)
|
|
|
|
(define-format-command #\s
|
|
(lambda (string i args out)
|
|
(check-for-format-arg args)
|
|
(write (car args) out)
|
|
(cdr args)))
|
|
|
|
; Recursion
|
|
|
|
(define-format-command #\?
|
|
(lambda (string i args out)
|
|
(check-for-format-arg args)
|
|
(check-for-format-arg (cdr args))
|
|
(real-format out (car args) (cadr args))
|
|
(cddr args)))
|
|
|
|
; Signal an error if ARGS is empty.
|
|
|
|
(define (check-for-format-arg args)
|
|
(if (null? args)
|
|
(error "insufficient number of arguments to FORMAT")))
|
|
|
|
|