DataMuseum.dk

top - download

    Length: 9468 (0x24fc)
    Types: TextFile
    Names: »format.scm.14«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/format.scm.14« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Output Formatter

(declare (usual-integrations))

;;; Please don't believe this implementation!  I don't like either the
;;; calling interface or the control string syntax, but I need the
;;; functionality pretty badly and I don't have the time to think
;;; about all of that right now -- CPH.

(define format)

(let ()
\f


;;;; Top Level

(set! format
      (named-lambda (format stream-or-string . arguments)
	(cond ((null? stream-or-string)
	       (if (conjunction (not (null? arguments))
				(string? (car arguments)))
		   (with-output-to-string
		    (lambda ()
		      (format-loop (car arguments) (cdr arguments))))
		   (error "Missing format string" 'FORMAT)))
	      ((string? stream-or-string)
	       (format-loop stream-or-string arguments)
	       *the-non-printing-object*)
	      ((output-stream? stream-or-string)
	       (if (conjunction (not (null? arguments))
				(string? (car arguments)))
		   (sequence (with-output-to-stream stream-or-string
			       (lambda ()
				 (format-loop (car arguments) (cdr arguments))))
			     *the-non-printing-object*)
		   (error "Missing format string" 'FORMAT)))
	      (else
	       (error "Unrecognizable first argument" 'FORMAT
		      stream-or-string)))))

(define (format-loop string arguments)
  (let ((index (string-position string #o177 #/~)))
    (cond (index
	   (if (not (zero? index))
	       (*unparse-string (substring string 0 index)))
	   (parse-dispatch (string-tail string (1+ index))
			   arguments
			   '()
			   '()
			   (lambda (remaining-string remaining-arguments)
			     (format-loop remaining-string
					  remaining-arguments))))
	  ((null? arguments)
	   (*unparse-string string))
	  (else
	   (error "Too many arguments" 'FORMAT arguments)))))

(define (parse-dispatch string supplied-arguments parsed-arguments modifiers
			receiver)
  ((vector-ref format-dispatch-table (string-ref string 0))
   string
   supplied-arguments
   parsed-arguments
   modifiers
   receiver))
\f


;;;; Argument Parsing

(define ((format-wrapper operator) 
	 string supplied-arguments parsed-arguments modifiers receiver)
  ((apply* operator modifiers (reverse! parsed-arguments))
   (string-tail string 1)
   supplied-arguments
   receiver))

(define ((parse-modifier keyword)
	 string supplied-arguments parsed-arguments modifiers receiver)
  (parse-dispatch (string-tail string 1)
		  supplied-arguments
		  parsed-arguments
		  (cons keyword modifiers)
		  receiver))

(define (parse-digit string supplied-arguments parsed-arguments modifiers
		     receiver)
  (let accumulate ((acc (- (string-ref string 0) #/0))
		   (i 1))
    (if (digit? (string-ref string i))
	(accumulate (+ (* acc 10) (- (string-ref string i) #/0))
		    (1+ i))
	(parse-dispatch (string-tail string i)
			supplied-arguments
			(cons acc parsed-arguments)
			modifiers
			receiver))))

;;; **** We shouldn't really depend on this bit vector being there.
;;; But it is expedient to do so for right now.

(define (digit? character)
  (vector-1b-ref *digit-bit* character))

(define (parse-ignore string supplied-arguments parsed-arguments modifiers
		      receiver)
  (parse-dispatch (string-tail string 1)
		  supplied-arguments
		  parsed-arguments
		  modifiers
		  receiver))

(define (parse-arity string supplied-arguments parsed-arguments modifiers
		     receiver)
  (parse-dispatch (string-tail string 1)
		  supplied-arguments
		  (cons (length supplied-arguments) parsed-arguments)
		  modifiers
		  receiver))

(define (parse-argument string supplied-arguments parsed-arguments modifiers
			receiver)
  (parse-dispatch (string-tail string 1)
		  (cdr supplied-arguments)
		  (cons (car supplied-arguments) parsed-arguments)
		  modifiers
		  receiver))

(define (string-tail string index)
  (substring string index (string-size string)))
\f


;;;; Formatters

(define (((format-insert-character character) modifiers #!optional n)
	 string arguments receiver)
  (if (unassigned? n)
      (*unparse-character character)
      (let loop ((i 0))
	(if (not (= i n))
	    (sequence (*unparse-character character)
		      (loop (1+ i))))))
  (receiver string arguments))

(define format-insert-return (format-insert-character #\CR))
(define format-insert-tilde (format-insert-character #/~))
(define format-insert-space (format-insert-character #\SP))

(define ((format-ignore-comment modifiers) string arguments receiver)
  (receiver (substring string
		       (1+ (string-position string #o177 #\CR))
		       (string-size string))
	    arguments))
\f


(define ((format-string modifiers #!optional n-columns)
	 string arguments receiver)
  (if (null? arguments)
      (error "Too few arguments" 'FORMAT string))
  (if (unassigned? n-columns)
      (*unparse-string (car arguments))
      (unparse-string-into-fixed-size (car arguments) n-columns modifiers))
  (receiver string (cdr arguments)))

(define ((format-object modifiers #!optional n-columns)
	 string arguments receiver)
  (if (null? arguments)
      (error "Too few arguments" 'FORMAT string))
  (if (unassigned? n-columns)
      (*unparse-object (car arguments))
      (unparse-object-into-fixed-size (car arguments) n-columns modifiers))
  (receiver string (cdr arguments)))

(define ((format-code modifiers #!optional n-columns)
	 string arguments receiver)
  (if (null? arguments)
      (error "Too few arguments" 'FORMAT string))
  (if (unassigned? n-columns)
      (*unparse-object (unsyntax (car arguments)))
      (unparse-object-into-fixed-size (unsyntax (car arguments))
				      n-columns
				      modifiers))
  (receiver string (cdr arguments)))

(define (unparse-object-into-fixed-size object n-columns modifiers)
  (unparse-string-into-fixed-size (prin1-to-string object)
				  n-columns
				  modifiers))

(define (unparse-string-into-fixed-size string n-columns modifiers)
  (let ((padding (- n-columns (string-size string))))
    (cond ((zero? padding)
	   (*unparse-string string))
	  ((positive? padding)
	   (let ((pad-string (make-filled-string padding #\SP)))
	     (if (memq 'AT modifiers)
		 (sequence (*unparse-string string)
			   (*unparse-string pad-string))
		 (sequence (*unparse-string pad-string)
			   (*unparse-string string)))))
	  ;; This is pretty random -- figure out something better.
	  ((memq 'COLON modifiers)
	   (*unparse-string (substring string 0 (- n-columns 4)))
	   (*unparse-string " ..."))
	  (else
	   (*unparse-string (substring string 0 n-columns))))))
\f


;;;; Dispatcher Setup

(define format-dispatch-table
  (make-initialized-vector
   128
   (lambda ((character)
	    string supplied-arguments parsed-arguments modifiers receiver)
     (error "Unknown formatting character" 'FORMAT character))))

(define (add-dispatcher! character dispatcher)
  (vector-set! format-dispatch-table character dispatcher))

(define (add-canonical-dispatcher! letter dispatcher)
  (add-dispatcher! letter dispatcher)
  (add-dispatcher! (character-upcase letter) dispatcher))

(add-dispatcher! #/0 parse-digit)
(add-dispatcher! #/1 parse-digit)
(add-dispatcher! #/2 parse-digit)
(add-dispatcher! #/3 parse-digit)
(add-dispatcher! #/4 parse-digit)
(add-dispatcher! #/5 parse-digit)
(add-dispatcher! #/6 parse-digit)
(add-dispatcher! #/7 parse-digit)
(add-dispatcher! #/8 parse-digit)
(add-dispatcher! #/9 parse-digit)
(add-dispatcher! #/, parse-ignore)
(add-dispatcher! #/# parse-arity)
(add-canonical-dispatcher! #/v parse-argument)
(add-dispatcher! #/@ (parse-modifier 'AT))
(add-dispatcher! #/: (parse-modifier 'COLON))

(add-dispatcher! #/% (format-wrapper format-insert-return))
(add-dispatcher! #/~ (format-wrapper format-insert-tilde))
(add-canonical-dispatcher! #/x (format-wrapper format-insert-space))
(add-dispatcher! #/; (format-wrapper format-ignore-comment))
(add-canonical-dispatcher! #/s (format-wrapper format-string))
(add-canonical-dispatcher! #/o (format-wrapper format-object))
(add-canonical-dispatcher! #/c (format-wrapper format-code))

;;; end LET.
)