home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / format.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  239 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: format.scm,v 14.6 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Output Formatter
  23. ;;; package: (runtime format)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;; Please don't believe this implementation!  I don't like either the
  28. ;;; calling interface or the control string syntax, but I need the
  29. ;;; functionality pretty badly and I don't have the time to think
  30. ;;; about all of that right now -- CPH.
  31.  
  32. ;;; (format port format-string argument ...)
  33. ;;;
  34. ;;; Format strings are normally interpreted literally, except that
  35. ;;; certain escape sequences allow insertion of computed values.  The
  36. ;;; following escape sequences are recognized:
  37. ;;;
  38. ;;; ~n% inserts n newlines
  39. ;;; ~n~ inserts n tildes
  40. ;;;
  41. ;;; ~<c> inserts the next argument.
  42. ;;; ~n<c> pads the argument on the left to size n.
  43. ;;; ~n@<c> pads the argument on the right to size n.
  44. ;;;
  45. ;;; where <c> may be:
  46. ;;; A meaning the argument is printed using `display'.
  47. ;;; S meaning the argument is printed using `write'.
  48.  
  49. ;;;; Top Level
  50.  
  51. (define (format destination format-string . arguments)
  52.   (if (not (string? format-string))
  53.       (error "FORMAT: illegal format string" format-string))
  54.   (let ((start
  55.      (lambda (port)
  56.        (format-loop port format-string arguments)
  57.        (output-port/discretionary-flush port))))
  58.     (cond ((not destination)
  59.        (with-output-to-string (lambda () (start (current-output-port)))))
  60.       ((eq? destination true)
  61.        (start (current-output-port)))
  62.       ((output-port? destination)
  63.        (start destination))
  64.       (else
  65.        (error "FORMAT: illegal destination" destination)))))
  66.  
  67. (define (format-loop port string arguments)
  68.   (let ((index (string-find-next-char string #\~)))
  69.     (cond (index
  70.        (if (not (zero? index))
  71.            (output-port/write-string port (substring string 0 index)))
  72.        (parse-dispatch port
  73.                (string-tail string (1+ index))
  74.                arguments
  75.                '()
  76.                '()))
  77.       ((null? arguments)
  78.        (output-port/write-string port string))
  79.       (else
  80.        (error "FORMAT: Too many arguments" arguments)))))
  81.  
  82. (define (parse-dispatch port string supplied-arguments parsed-arguments
  83.             modifiers)
  84.   ((vector-ref format-dispatch-table (vector-8b-ref string 0))
  85.    port
  86.    string
  87.    supplied-arguments
  88.    parsed-arguments
  89.    modifiers))
  90.  
  91. (define format-dispatch-table)
  92.  
  93. (define (parse-default port string supplied-arguments parsed-arguments
  94.                modifiers)
  95.   port supplied-arguments parsed-arguments modifiers ;ignore
  96.   (error "FORMAT: Unknown formatting character" (string-ref string 0)))
  97.  
  98. ;;;; Argument Parsing
  99.  
  100. (define ((format-wrapper operator)
  101.      port string supplied-arguments parsed-arguments modifiers)
  102.   ((apply operator modifiers (reverse! parsed-arguments))
  103.    port
  104.    (string-tail string 1)
  105.    supplied-arguments))
  106.  
  107. (define ((parse-modifier keyword)
  108.      port string supplied-arguments parsed-arguments modifiers)
  109.   (parse-dispatch port
  110.           (string-tail string 1)
  111.           supplied-arguments
  112.           parsed-arguments
  113.           (cons keyword modifiers)))
  114.  
  115. (define (parse-digit port string supplied-arguments parsed-arguments modifiers)
  116.   (let accumulate ((acc (char->digit (string-ref string 0) 10)) (i 1))
  117.     (if (char-numeric? (string-ref string i))
  118.     (accumulate (+ (* acc 10) (char->digit (string-ref string i) 10))
  119.             (1+ i))
  120.     (parse-dispatch port
  121.             (string-tail string i)
  122.             supplied-arguments
  123.             (cons acc parsed-arguments)
  124.             modifiers))))
  125.  
  126. (define (parse-ignore port string supplied-arguments parsed-arguments
  127.               modifiers)
  128.   (parse-dispatch port (string-tail string 1) supplied-arguments
  129.           parsed-arguments modifiers))
  130.  
  131. (define (parse-arity port string supplied-arguments parsed-arguments modifiers)
  132.   (parse-dispatch port
  133.           (string-tail string 1)
  134.           supplied-arguments
  135.           (cons (length supplied-arguments) parsed-arguments)
  136.           modifiers))
  137.  
  138. (define (parse-argument port string supplied-arguments parsed-arguments
  139.             modifiers)
  140.   (parse-dispatch port
  141.           (string-tail string 1)
  142.           (cdr supplied-arguments)
  143.           (cons (car supplied-arguments) parsed-arguments)
  144.           modifiers))
  145.  
  146. ;;;; Formatters
  147.  
  148. (define (((format-insert-character character) modifiers #!optional n)
  149.      port string arguments)
  150.   (if (default-object? n)
  151.       (output-port/write-char port character)
  152.       (let loop ((i 0))
  153.     (if (not (= i n))
  154.         (begin (output-port/write-char port character)
  155.            (loop (1+ i))))))
  156.   (format-loop port string arguments))
  157.  
  158. (define ((format-ignore-comment modifiers) port string arguments)
  159.   modifiers                ;ignore
  160.   (format-loop port
  161.            (substring string
  162.               (1+ (string-find-next-char string #\Newline))
  163.               (string-length string))
  164.            arguments))
  165.  
  166. (define ((format-ignore-whitespace modifiers) port string arguments)
  167.   (format-loop port
  168.            (cond ((null? modifiers) (eliminate-whitespace string))
  169.              ((memq 'AT modifiers)
  170.               (string-append "\n" (eliminate-whitespace string)))
  171.              (else string))
  172.            arguments))
  173.  
  174. (define (eliminate-whitespace string)
  175.   (let ((limit (string-length string)))
  176.     (let loop ((n 0))
  177.       (cond ((= n limit) "")
  178.         ((let ((char (string-ref string n)))
  179.            (and (char-whitespace? char)
  180.             (not (char=? char #\Newline))))
  181.          (loop (1+ n)))
  182.         (else
  183.          (substring string n limit))))))
  184.  
  185. (define (((format-object write) modifiers #!optional n-columns)
  186.      port string arguments)
  187.   (if (null? arguments)
  188.       (error "FORMAT: too few arguments" string))
  189.   (if (default-object? n-columns)
  190.       (write (car arguments) port)
  191.       (output-port/write-string port
  192.                 ((if (memq 'AT modifiers)
  193.                      string-pad-left
  194.                      string-pad-right)
  195.                  (with-output-to-string
  196.                    (lambda ()
  197.                      (write (car arguments))))
  198.                  n-columns)))
  199.   (format-loop port string (cdr arguments)))
  200.  
  201. ;;;; Dispatcher Setup
  202.  
  203. (define (initialize-package!)
  204.   (set! format-dispatch-table
  205.     (let ((table (make-vector 256 parse-default)))
  206.       (for-each (lambda (entry)
  207.               (vector-set! table
  208.                    (char->ascii (car entry))
  209.                    (cadr entry)))
  210.             (let ((format-string
  211.                (format-wrapper (format-object display)))
  212.               (format-object
  213.                (format-wrapper (format-object write))))
  214.               `((#\0 ,parse-digit)
  215.             (#\1 ,parse-digit)
  216.             (#\2 ,parse-digit)
  217.             (#\3 ,parse-digit)
  218.             (#\4 ,parse-digit)
  219.             (#\5 ,parse-digit)
  220.             (#\6 ,parse-digit)
  221.             (#\7 ,parse-digit)
  222.             (#\8 ,parse-digit)
  223.             (#\9 ,parse-digit)
  224.             (#\, ,parse-ignore)
  225.             (#\# ,parse-arity)
  226.             (#\V ,parse-argument)
  227.             (#\v ,parse-argument)
  228.             (#\@ ,(parse-modifier 'AT))
  229.             (#\: ,(parse-modifier 'COLON))
  230.             (#\%
  231.              ,(format-wrapper (format-insert-character #\Newline)))
  232.             (#\~ ,(format-wrapper (format-insert-character #\~)))
  233.             (#\; ,(format-wrapper format-ignore-comment))
  234.             (#\Newline ,(format-wrapper format-ignore-whitespace))
  235.             (#\A ,format-string)
  236.             (#\a ,format-string)
  237.             (#\S ,format-object)
  238.             (#\s ,format-object))))
  239.       table)))