format.scm

MSYS在windows下模拟了一个类unix的终端

;;;; "format.scm" Common LISP text output formatter for SLIB
;;; Written 1992-1994 by Dirk Lutzebaeck ([e-mail])
;;; Assimilated into Guile May 1999
;
; This code is in the public domain.

; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
; Please send error reports to [e-mail].
; For documentation see slib.texi and format.doc.
; For testing load formatst.scm.
;
; Version 3.0

(define-module (ice-9 format)
  :use-module (ice-9 and-let-star)
  :autoload (ice-9 pretty-print) (pretty-print))

(begin-deprecated
 ;; So that `export' below will not accidentally re-export the
 ;; `format' of the `(guile)' module.
 (define format #f))

(export format
	format:symbol-case-conv
	format:iobj-case-conv
	format:expch)

;;; Configuration ------------------------------------------------------------

(define format:symbol-case-conv #f)
;; Symbols are converted by symbol->string so the case of the printed
;; symbols is implementation dependent. format:symbol-case-conv is a
;; one arg closure which is either #f (no conversion), string-upcase!,
;; string-downcase! or string-capitalize!.

(define format:iobj-case-conv #f)
;; As format:symbol-case-conv but applies for the representation of
;; implementation internal objects.

(define format:expch #\E)
;; The character prefixing the exponent value in ~e printing.

(define format:floats (provided? 'inexact))
;; Detects if the scheme system implements flonums (see at eof).

(define format:complex-numbers (provided? 'complex))
;; Detects if the scheme system implements complex numbers.

(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
;; Detects if number->string adds a radix prefix.

(define format:ascii-non-printable-charnames
  '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
     "bs"  "ht"  "nl"  "vt"  "np"  "cr"  "so"  "si"
     "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
     "can" "em"  "sub" "esc" "fs"  "gs"  "rs"  "us" "space"))

;;; End of configuration ----------------------------------------------------

(define format:version "3.0")
(define format:port #f)			; curr. format output port
(define format:output-col 0)		; curr. format output tty column
(define format:flush-output #f)		; flush output at end of formatting
(define format:case-conversion #f)
(define format:error-continuation #f)
(define format:args #f)
(define format:pos 0)			; curr. format string parsing position
(define format:arg-pos 0)		; curr. format argument position
					; this is global for error presentation

; format string and char output routines on format:port

(define (format:out-str str)
  (if format:case-conversion
      (display (format:case-conversion str) format:port)
      (display str format:port))
  (set! format:output-col
	(+ format:output-col (string-length str))))

(define (format:out-char ch)
  (if format:case-conversion
      (display (format:case-conversion (string ch)) format:port)
      (write-char ch format:port))
  (set! format:output-col
	(if (char=? ch #\newline)
	    0
	    (+ format:output-col 1))))

;(define (format:out-substr str i n)  ; this allocates a new string
;  (display (substring str i n) format:port)
;  (set! format:output-col (+ format:output-col n)))

(define (format:out-substr str i n)
  (do ((k i (+ k 1)))
      ((= k n))
    (write-char (string-ref str k) format:port))
  (set! format:output-col (+ format:output-col n)))

;(define (format:out-fill n ch)       ; this allocates a new string
;  (format:out-str (make-string n ch)))

(define (format:out-fill n ch)
  (do ((i 0 (+ i 1)))
      ((= i n))
    (write-char ch format:port))
  (set! format:output-col (+ format:output-col n)))

; format's user error handler

(define (format:error . args)		; never returns!
  (let ((error-continuation format:error-continuation)
	(format-args format:args)
	(port (current-error-port)))
    (set! format:error format:intern-error)
    (if (and (>= (length format:args) 2)
	     (string? (cadr format:args)))
	(let ((format-string (cadr format-args)))
	  (if (not (zero? format:arg-pos))
	      (set! format:arg-pos (- format:arg-pos 1)))
	  (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
                                  ~{~a ~}===>~{~a ~})~%        "
		  (car format:args)
		  (substring format-string 0 format:pos)
		  (substring format-string format:pos
			     (string-length format-string))
		  (list-head (cddr format:args) format:arg-pos)
		  (list-tail (cddr format:args) format:arg-pos)))
	(format port 
		"~%FORMAT: error with call: (format~{ ~a~})~%        "
		format:args))
    (apply format port args)
    (newline port)
    (set! format:error format:error-save)
    (set! format:error-continuation error-continuation)
    (format:abort)
    (format:intern-error "format:abort does not jump to toplevel!")))

(define format:error-save format:error)

(define (format:intern-error . args)   ;if something goes wrong in format:error
  (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
  (display "        format args: ") (write format:args) (newline)
  (display "        error args:  ") (write args) (newline)
  (set! format:error format:error-save)
  (format:abort))

(define (format:format . args)		; the formatter entry
  (set! format:args args)
  (set! format:arg-pos 0)
  (set! format:pos 0)
  (if (< (length args) 1)
      (format:error "not enough arguments"))

  ;; If the first argument is a string, then that's the format string.
  ;; (Scheme->C)
  ;; In this case, put the argument list in canonical form.
  (let ((args (if (string? (car args))
		  (cons #f args)
		  args)))
    ;; Use this canonicalized version when reporting errors.
    (set! format:args args)

    (let ((destination (car args))
	  (arglist (cdr args)))
      (cond
       ((or (and (boolean? destination)	; port output
		 destination)
	    (output-port? destination)
	    (number? destination))
	(format:out (cond
		     ((boolean? destination) (current-output-port))
		     ((output-port? destination) destination)
		     ((number? destination) (current-error-port)))
		    (car arglist) (cdr arglist)))
       ((and (boolean? destination)	; string output
	     (not destination))
	(call-with-output-string
	 (lambda (port) (format:out port (car arglist) (cdr arglist)))))
       (else
	(format:error "illegal destination `~a'" destination))))))

(define (format:out port fmt args)	; the output handler for a port
  (set! format:port port)		; global port for output routines
  (set! format:case-conversion #f)	; modifier case conversion procedure
  (set! format:flush-output #f)		; ~! reset
  (and-let* ((col (port-column port)))	; get current column from port
    (set! format:output-col col))
  (let ((arg-pos (format:format-work fmt args))
	(arg-len (length args)))
    (cond
     ((< arg-pos arg-len)
      (set! format:arg-pos (+ arg-pos 1))
      (set! format:pos (string-length fmt))
      (format:error "~a superfluous argument~:p" (- arg-len arg-pos)))
     ((> arg-pos arg-len)
      (set! format:arg-pos (+ arg-len 1))
      (display format:arg-pos)
      (format:error "~a missing argument~:p" (- arg-pos arg-len)))
     (else
      (if format:flush-output (force-output port))
      #t))))

(define format:parameter-characters
  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))

(define (format:format-work format-string arglist) ; does the formatting work
  (letrec
      ((format-string-len (string-length format-string))
       (arg-pos 0)			; argument position in arglist
       (arg-len (length arglist))	; number of arguments
       (modifier #f)			; 'colon | 'at | 'colon-at | #f
       (params '())			; directive parameter list
       (param-value-found #f)		; a directive parameter value found
       (conditional-nest 0)		; conditional nesting level
       (clause-pos 0)			; last cond. clause beginning char pos
       (clause-default #f)		; conditional default clause string
       (clauses '())			; conditional clause string list
       (conditional-type #f)		; reflects the contional modifiers
       (conditional-arg #f)		; argument to apply the conditional
       (iteration-nest 0)		; iteration nesting level
       (iteration-pos 0)		; iteration string beginning char pos
       (iteration-type #f)		; reflects the iteration modifiers
       (max-iterations #f)		; maximum number of iterations
       (recursive-pos-save format:pos)

       (next-char			; gets the next char from format-string
	(lambda ()
	  (let ((ch (peek-next-char)))
	    (set! format:pos (+ 1 format:pos))
	    ch)))

       (peek-next-char
	(lambda ()
	  (if (>= format:pos format-string-len)
	      (format:error "illegal format string")
	      (string-ref format-string format:pos))))

       (one-positive-integer?
	(lambda (params)
	  (cond
	   ((null? params) #f)
	   ((and (integer? (car params))
		 (>= (car params) 0)
		 (= (length params) 1)) #t)
	   (else (format:error "one positive integer parameter expected")))))

       (next-arg
	(lambda ()
	  (if (>= arg-pos arg-len)
	      (begin
		(set! format:arg-pos (+ arg-len 1))
		(format:error "missing argument(s)")))
	  (add-arg-pos 1)
	  (list-ref arglist (- arg-pos 1))))

       (prev-arg
	(lambda ()
	  (add-arg-pos -1)
	  (if (negative? arg-pos)
	      (format:error "missing backward argument(s)"))
	  (list-ref arglist arg-pos)))

       (rest-args
	(lambda ()
	  (let loop ((l arglist) (k arg-pos)) ; list-tail definition
	    (if (= k 0) l (loop (cdr l) (- k 1))))))

       (add-arg-pos
	(lambda (n) 
	  (set! arg-pos (+ n arg-pos))
	  (set! format:arg-pos arg-pos)))

       (anychar-dispatch		; dispatches the format-string
	(lambda ()
	  (if (>= format:pos format-string-len)
	      arg-pos			; used for ~? continuance
	      (let ((char (next-char)))
		(cond
		 ((char=? char #\~)
		  (set! modifier #f)
		  (set! params '())
		  (set! param-value-found #f)
		  (tilde-dispatch))
		 (else
		  (if (and (zero? conditional-nest)
			   (zero? iteration-nest))
		      (format:out-char char))
		  (anychar-dispatch)))))))

       (tilde-dispatch
	(lambda ()
	  (cond
	   ((>= format:pos format-string-len)
	    (format:out-str "~")	; tilde at end of string is just output
	    arg-pos)			; used for ~? continuance
	   ((and (or (zero? conditional-nest)
		     (memv (peek-next-char) ; find conditional directives
			   (append '(#\[ #\] #\; #\: #\@ #\^)
				   format:parameter-characters)))
		 (or (zero? iteration-nest)
		     (memv (peek-next-char) ; find iteration directives
			   (append '(#\{ #\} #\: #\@ #\^)
				   format:parameter-characters))))
	    (case (char-upcase (next-char))

	      ;; format directives

	      ((#\A)			; Any -- for humans
	       (set! format:read-proof (memq modifier '(colon colon-at)))
	       (format:out-obj-padded (memq modifier '(at colon-at))
				      (next-arg) #f params)
	       (anychar-dispatch))
	      ((#\S)			; Slashified -- for parsers
	       (set! format:read-proof (memq modifier '(colon colon-at)))
	       (format:out-obj-padded (memq modifier '(at colon-at))
				      (next-arg) #t params)
	       (anychar-dispatch))
	      ((#\D)			; Decimal
	       (format:out-num-padded modifier (next-arg) params 10)
	       (anychar-dispatch))
	      ((#\X)			; Hexadecimal
	       (format:out-num-padded modifier (next-arg) params 16)
	       (anychar-dispatch))
	      ((#\O)			; Octal
	       (format:out-num-padded modifier (next-arg) params 8)
	       (anychar-dispatch))
	      ((#\B)			; Binary
	       (format:out-num-padded modifier (next-arg) params 2)
	       (anychar-dispatch))
	      ((#\R)
	       (if (null? params)
		   (format:out-obj-padded ; Roman, cardinal, ordinal numerals
		    #f
		    ((case modifier
		       ((at) format:num->roman)
		       ((colon-at) format:num->old-roman)
		       ((colon) format:num->ordinal)
		       (else format:num->cardinal))
		     (next-arg))
		    #f params)
		   (format:out-num-padded ; any Radix
		    modifier (next-arg) (cdr params) (car params)))
	       (anychar-dispatch))
	      ((#\F)			; Fixed-format floating-point
	       (if format:floats
		   (format:out-fixed modifier (next-arg) params)
		   (format:out-str (number->string (next-arg))))
	       (anychar-dispatch))
	      ((#\E)			; Exponential floating-point
	       (if format:floats
		   (format:out-expon modifier (next-arg) params)
		   (format:out-str (number->string (next-arg))))
	       (anychar-dispatch))
	      ((#\G)			; General floating-point
	       (if format:floats
		   (format:out-general modifier (next-arg) params)
		   (format:out-str (number->string (next-arg))))
	       (anychar-dispatch))
	      ((#\$)			; Dollars floating-point
	       (if format:floats
		   (format:out-dollar modifier (next-arg) params)
		   (format:out-str (number->string (next-arg))))
	       (anychar-dispatch))
	      ((#\I)			; Complex numbers
	       (if (not format:complex-numbers)
		   (format:error
		    "complex numbers not supported by this scheme system"))
	       (let ((z (next-arg)))
		 (if (not (complex? z))
		     (format:error "argument not a complex number"))
		 (format:out-fixed modifier (real-part z) params)
		 (format:out-fixed 'at (imag-part z) params)
		 (format:out-char #\i))
	       (anychar-dispatch))
	      ((#\C)			; Character
	       (let ((ch (if (one-positive-integer? params)
			     (integer->char (car params))
			     (next-arg))))
		 (if (not (char? ch)) (format:error "~~c expects a character"))
		 (case modifier
		   ((at)
		    (format:out-str (format:char->str ch)))
		   ((colon)
		    (let ((c (char->integer ch)))
		      (if (< c 0)
			  (set! c (+ c 256))) ; compensate complement impl.
		      (cond
		       ((< c #x20)	; assumes that control chars are < #x20
			(format:out-char #\^)
			(format:out-char
			 (integer->char (+ c #x40))))
		       ((>= c #x7f)
			(format:out-str "#\\")
			(format:out-str
			 (if format:radix-pref
			     (let ((s (number->string c 8)))
			       (substring s 2 (string-length s)))
			     (number->string c 8))))
		       (else
			(format:out-char ch)))))
		   (else (format:out-char ch))))
	       (anychar-dispatch))
	      ((#\P)			; Plural
	       (if (memq modifier '(colon colon-at))
		   (prev-arg))
	       (let ((arg (next-arg)))
		 (if (not (number? arg))
		     (format:error "~~p expects a number argument"))
		 (if (= arg 1)
		     (if (memq modifier '(at colon-at))
			 (format:out-char #\y))
		     (if (memq modifier '(at colon-at))
			 (format:out-str "ies")
			 (format:out-char #\s))))
	       (anychar-dispatch))
	      ((#\~)			; Tilde
	       (if (one-positive-integer? params)
		   (format:out-fill (car params) #\~)
		   (format:out-char #\~))
	       (anychar-dispatch))
	      ((#\%)			; Newline
	       (if (one-positive-integer? params)
		   (format:out-fill (car params) #\newline)
		   (format:out-char #\newline))
	       (set! format:output-col 0)
	       (anychar-dispatch))
	      ((#\&)			; Fresh line
	       (if (one-positive-integer? params)
		   (begin