home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
s
/
s48.zip
/
MISC
/
FORMAT.SCM
< prev
next >
Wrap
Text File
|
1992-07-06
|
4KB
|
152 lines
; Copyright (c) 1992 by 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)
(let ((port (make-string-output-port)))
(real-format port string args)
(string-output-port-output port)))
((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)
(values)
(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->integer (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->INTEGER may return.
(define number-of-char-codes 256) ; just a guess
; 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->integer char) proc)
(if (char-alphabetic? char)
(vector-set! format-dispatch-vector
(char->integer (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")))