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 >
Text File  |  1992-07-06  |  4KB  |  152 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Quicky FORMAT
  5. ;
  6. ; (FORMAT port string . args)
  7. ;
  8. ; PORT is one of:
  9. ; an output port, in which case FORMAT prints to the port;
  10. ; #T, FORMAT prints to the current output port;
  11. ; #F, FORMAT returns a string.
  12. ;
  13. ; The following format directives have been implemented:
  14. ; ~~  -prints a single ~
  15. ; ~A  -prints the next argument using DISPLAY
  16. ; ~S  -prints the next argument using WRITE
  17. ; ~%  -prints a NEWLINE character
  18. ; ~&  -prints a NEWLINE character if the previous printed character was not one
  19. ;     (this is implemented using FRESH-LINE)
  20. ; ~?  -performs a recursive call to FORMAT using the next two arguments as the
  21. ;      string and the list of arguments
  22. ;
  23. ; FORMAT is case-insensitive with respect to letter directives (~a and ~A have
  24. ; the same effect).
  25.  
  26. ; The entry point.  Gets the port and writes the output.
  27. ; Get the appropriate writer for the port specification.
  28.  
  29. (define (format port string . args)
  30.   (cond ((not port)
  31.      (let ((port (make-string-output-port)))
  32.        (real-format port string args)
  33.        (string-output-port-output port)))
  34.     ((eq? port #t)
  35.      (real-format (current-output-port) string args))
  36.     ((output-port? port)
  37.      (real-format port string args))
  38.     (else
  39.      (error "invalid port argument to FORMAT" port))))
  40.  
  41. ; Loop down the format string printing characters and dispatching on directives
  42. ; as required.  Procedures for the directives are in a vector indexed by
  43. ; character codes.  Each procedure takes four arguments: the format string,
  44. ; the index of the next unsed character in the format string, the list of
  45. ; remaining arguments, and the writer.  Each should return a list of the unused
  46. ; arguments.
  47.  
  48. (define (real-format out string all-args)
  49.   (let loop ((i 0) (args all-args))
  50.     (cond ((>= i (string-length string))
  51.        (if (null? args)
  52.            (values)
  53.            (error "too many arguments to FORMAT" string all-args)))
  54.       ((char=? #\~ (string-ref string i))
  55.        (if (= (+ i 1) (string-length string))
  56.            (error "invalid format string" string i)
  57.            (loop (+ i 2)
  58.              ((vector-ref format-dispatch-vector
  59.                   (char->integer (string-ref string (+ i 1))))
  60.               string
  61.               (+ i 2)
  62.               args
  63.               out))))
  64.       (else
  65.        (write-char (string-ref string i) out)
  66.        (loop (+ i 1) args)))))
  67.  
  68. ; One more than the highest integer that CHAR->INTEGER may return.
  69. (define number-of-char-codes 256)  ; just a guess
  70.  
  71. ; The vector of procedures implementing format directives.
  72.  
  73. (define format-dispatch-vector
  74.   (make-vector number-of-char-codes
  75.            (lambda (string i args out)
  76.          (error "illegal format command"
  77.             string
  78.             (string-ref string (- i 1))))))
  79.  
  80. ; This implements FORMATs case-insensitivity.
  81.  
  82. (define (define-format-command char proc)
  83.   (vector-set! format-dispatch-vector (char->integer char) proc)
  84.   (if (char-alphabetic? char)
  85.       (vector-set! format-dispatch-vector
  86.            (char->integer (if (char-lower-case? char)
  87.                       (char-upcase char)
  88.                       (char-downcase char)))
  89.            proc)))
  90.  
  91. ; Write a single ~ character.
  92.  
  93. (define-format-command #\~
  94.   (lambda (string i args out)
  95.     (write-char #\~ out)
  96.     args))
  97.  
  98. ; Newline
  99.  
  100. (define-format-command #\%
  101.   (lambda (string i args out)
  102.     (newline out)
  103.     args))
  104.  
  105. ; Fresh-Line
  106.  
  107. (define-format-command #\&
  108.   (lambda (string i args out)
  109.     (fresh-line out)
  110.     args))
  111.  
  112. ; Display (`A' is for ASCII)
  113.  
  114. (define-format-command #\a
  115.   (lambda (string i args out)
  116.     (check-for-format-arg args)
  117.     (display (car args) out)
  118.     (cdr args)))
  119.  
  120. ; Decimals
  121.  
  122. (define-format-command #\d
  123.   (lambda (string i args out)
  124.     (check-for-format-arg args)
  125.     (display (number->string (car args) 10) out)
  126.     (cdr args)))
  127.  
  128. ; Write (`S' is for S-expression)
  129.  
  130. (define-format-command #\s
  131.   (lambda (string i args out)
  132.     (check-for-format-arg args)
  133.     (write (car args) out)
  134.     (cdr args)))
  135.  
  136. ; Recursion
  137.  
  138. (define-format-command #\?
  139.   (lambda (string i args out)
  140.     (check-for-format-arg args)
  141.     (check-for-format-arg (cdr args))
  142.     (real-format out (car args) (cadr args))
  143.     (cddr args)))
  144.  
  145. ; Signal an error if ARGS is empty.
  146.  
  147. (define (check-for-format-arg args)
  148.   (if (null? args)
  149.       (error "insufficient number of arguments to FORMAT")))
  150.  
  151.  
  152.