format.scm

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

		     (if (> (car params) 0)
			 (format:out-fill (- (car params)
					     (if (> format:output-col 0) 0 1))
					  #\newline))
		     (set! format:output-col 0))
		   (if (> format:output-col 0)
		       (format:out-char #\newline)))
	       (anychar-dispatch))
	      ((#\_)			; Space character
	       (if (one-positive-integer? params)
		   (format:out-fill (car params) #\space)
		   (format:out-char #\space))
	       (anychar-dispatch))
	      ((#\/)			; Tabulator character
	       (if (one-positive-integer? params)
		   (format:out-fill (car params) #\tab)
		   (format:out-char #\tab))
	       (anychar-dispatch))
	      ((#\|)			; Page seperator
	       (if (one-positive-integer? params)
		   (format:out-fill (car params) #\page)
		   (format:out-char #\page))
	       (set! format:output-col 0)
	       (anychar-dispatch))
	      ((#\T)			; Tabulate
	       (format:tabulate modifier params)
	       (anychar-dispatch))
	      ((#\Y)			; Pretty-print
	       (pretty-print (next-arg) format:port)
	       (set! format:output-col 0)
	       (anychar-dispatch))
	      ((#\? #\K)		; Indirection (is "~K" in T-Scheme)
	       (cond
		((memq modifier '(colon colon-at))
		 (format:error "illegal modifier in ~~?"))
		((eq? modifier 'at)
		 (let* ((frmt (next-arg))
			(args (rest-args)))
		   (add-arg-pos (format:format-work frmt args))))
		(else
		 (let* ((frmt (next-arg))
			(args (next-arg)))
		   (format:format-work frmt args))))
	       (anychar-dispatch))
	      ((#\!)			; Flush output
	       (set! format:flush-output #t)
	       (anychar-dispatch))
	      ((#\newline)		; Continuation lines
	       (if (eq? modifier 'at)
		   (format:out-char #\newline))
	       (if (< format:pos format-string-len)
		   (do ((ch (peek-next-char) (peek-next-char)))
		       ((or (not (char-whitespace? ch))
			    (= format:pos (- format-string-len 1))))
		     (if (eq? modifier 'colon)
			 (format:out-char (next-char))
			 (next-char))))
	       (anychar-dispatch))
	      ((#\*)			; Argument jumping
	       (case modifier
		 ((colon)		; jump backwards
		  (if (one-positive-integer? params)
		      (do ((i 0 (+ i 1)))
			  ((= i (car params)))
			(prev-arg))
		      (prev-arg)))
		 ((at)			; jump absolute
		  (set! arg-pos (if (one-positive-integer? params)
				    (car params) 0)))
		 ((colon-at)
		  (format:error "illegal modifier `:@' in ~~* directive"))
		 (else			; jump forward
		  (if (one-positive-integer? params)
		      (do ((i 0 (+ i 1)))
			  ((= i (car params)))
			(next-arg))
		      (next-arg))))
	       (anychar-dispatch))
	      ((#\()			; Case conversion begin
	       (set! format:case-conversion
		     (case modifier
		       ((at) string-capitalize-first)
		       ((colon) string-capitalize)
		       ((colon-at) string-upcase)
		       (else string-downcase)))
	       (anychar-dispatch))
	      ((#\))			; Case conversion end
	       (if (not format:case-conversion)
		   (format:error "missing ~~("))
	       (set! format:case-conversion #f)
	       (anychar-dispatch))
	      ((#\[)			; Conditional begin
	       (set! conditional-nest (+ conditional-nest 1))
	       (cond
		((= conditional-nest 1)
		 (set! clause-pos format:pos)
		 (set! clause-default #f)
		 (set! clauses '())
		 (set! conditional-type
		       (case modifier
			 ((at) 'if-then)
			 ((colon) 'if-else-then)
			 ((colon-at) (format:error "illegal modifier in ~~["))
			 (else 'num-case)))
		 (set! conditional-arg
		       (if (one-positive-integer? params)
			   (car params)
			   (next-arg)))))
	       (anychar-dispatch))
	      ((#\;)                    ; Conditional separator
	       (if (zero? conditional-nest)
		   (format:error "~~; not in ~~[~~] conditional"))
	       (if (not (null? params))
		   (format:error "no parameter allowed in ~~;"))
	       (if (= conditional-nest 1)
		   (let ((clause-str
			  (cond
			   ((eq? modifier 'colon)
			    (set! clause-default #t)
			    (substring format-string clause-pos 
				       (- format:pos 3)))
			   ((memq modifier '(at colon-at))
			    (format:error "illegal modifier in ~~;"))
			   (else
			    (substring format-string clause-pos
				       (- format:pos 2))))))
		     (set! clauses (append clauses (list clause-str)))
		     (set! clause-pos format:pos)))
	       (anychar-dispatch))
	      ((#\])			; Conditional end
	       (if (zero? conditional-nest) (format:error "missing ~~["))
	       (set! conditional-nest (- conditional-nest 1))
	       (if modifier
		   (format:error "no modifier allowed in ~~]"))
	       (if (not (null? params))
		   (format:error "no parameter allowed in ~~]"))
	       (cond
		((zero? conditional-nest)
		 (let ((clause-str (substring format-string clause-pos
					      (- format:pos 2))))
		   (if clause-default
		       (set! clause-default clause-str)
		       (set! clauses (append clauses (list clause-str)))))
		 (case conditional-type
		   ((if-then)
		    (if conditional-arg
			(format:format-work (car clauses)
					    (list conditional-arg))))
		   ((if-else-then)
		    (add-arg-pos
		     (format:format-work (if conditional-arg
					     (cadr clauses)
					     (car clauses))
					 (rest-args))))
		   ((num-case)
		    (if (or (not (integer? conditional-arg))
			    (< conditional-arg 0))
			(format:error "argument not a positive integer"))
		    (if (not (and (>= conditional-arg (length clauses))
				  (not clause-default)))
			(add-arg-pos
			 (format:format-work
			  (if (>= conditional-arg (length clauses))
			      clause-default
			      (list-ref clauses conditional-arg))
			  (rest-args))))))))
	       (anychar-dispatch))
	      ((#\{)			; Iteration begin
	       (set! iteration-nest (+ iteration-nest 1))
	       (cond
		((= iteration-nest 1)
		 (set! iteration-pos format:pos)
		 (set! iteration-type
		       (case modifier
			 ((at) 'rest-args)
			 ((colon) 'sublists)
			 ((colon-at) 'rest-sublists)
			 (else 'list)))
		 (set! max-iterations (if (one-positive-integer? params)
					 (car params) #f))))
	       (anychar-dispatch))
	      ((#\})			; Iteration end
	       (if (zero? iteration-nest) (format:error "missing ~~{"))
	       (set! iteration-nest (- iteration-nest 1))
	       (case modifier
		 ((colon)
		  (if (not max-iterations) (set! max-iterations 1)))
		 ((colon-at at) (format:error "illegal modifier"))
		 (else (if (not max-iterations) (set! max-iterations 100))))
	       (if (not (null? params))
		   (format:error "no parameters allowed in ~~}"))
	       (if (zero? iteration-nest)
		 (let ((iteration-str
			(substring format-string iteration-pos
				   (- format:pos (if modifier 3 2)))))
		   (if (string=? iteration-str "")
		       (set! iteration-str (next-arg)))
		   (case iteration-type
		     ((list)
		      (let ((args (next-arg))
			    (args-len 0))
			(if (not (list? args))
			    (format:error "expected a list argument"))
			(set! args-len (length args))
			(do ((arg-pos 0 (+ arg-pos
					   (format:format-work
					    iteration-str
					    (list-tail args arg-pos))))
			     (i 0 (+ i 1)))
			    ((or (>= arg-pos args-len)
				 (>= i max-iterations))))))
		     ((sublists)
		      (let ((args (next-arg))
			    (args-len 0))
			(if (not (list? args))
			    (format:error "expected a list argument"))
			(set! args-len (length args))
			(do ((arg-pos 0 (+ arg-pos 1)))
			    ((or (>= arg-pos args-len)
				 (>= arg-pos max-iterations)))
			  (let ((sublist (list-ref args arg-pos)))
			    (if (not (list? sublist))
				(format:error
				 "expected a list of lists argument"))
			    (format:format-work iteration-str sublist)))))
		     ((rest-args)
		      (let* ((args (rest-args))
			     (args-len (length args))
			     (usedup-args
			      (do ((arg-pos 0 (+ arg-pos
						 (format:format-work
						  iteration-str
						  (list-tail
						   args arg-pos))))
				   (i 0 (+ i 1)))
				  ((or (>= arg-pos args-len)
				       (>= i max-iterations))
				   arg-pos))))
			(add-arg-pos usedup-args)))
		     ((rest-sublists)
		      (let* ((args (rest-args))
			     (args-len (length args))
			     (usedup-args
			      (do ((arg-pos 0 (+ arg-pos 1)))
				  ((or (>= arg-pos args-len)
				       (>= arg-pos max-iterations))
				   arg-pos)
				(let ((sublist (list-ref args arg-pos)))
				  (if (not (list? sublist))
				      (format:error "expected list arguments"))
				  (format:format-work iteration-str sublist)))))
			(add-arg-pos usedup-args)))
		     (else (format:error "internal error in ~~}")))))
	       (anychar-dispatch))
	      ((#\^)			; Up and out
	       (let* ((continue
		       (cond
			((not (null? params))
			 (not
			  (case (length params)
			   ((1) (zero? (car params)))
			   ((2) (= (list-ref params 0) (list-ref params 1)))
			   ((3) (<= (list-ref params 0)
				    (list-ref params 1)
				    (list-ref params 2)))
			   (else (format:error "too much parameters")))))
			(format:case-conversion ; if conversion stop conversion
			 (set! format:case-conversion string-copy) #t)
			((= iteration-nest 1) #t)
			((= conditional-nest 1) #t)
			((>= arg-pos arg-len)
			 (set! format:pos format-string-len) #f)
			(else #t))))
		 (if continue
		     (anychar-dispatch))))

	      ;; format directive modifiers and parameters

	      ((#\@)			; `@' modifier
	       (if (memq modifier '(at colon-at))
		   (format:error "double `@' modifier"))
	       (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
	       (tilde-dispatch))
	      ((#\:)			; `:' modifier
	       (if (memq modifier '(colon colon-at))
		   (format:error "double `:' modifier"))
	       (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
	       (tilde-dispatch))
	      ((#\')			; Character parameter
	       (if modifier (format:error "misplaced modifier"))
	       (set! params (append params (list (char->integer (next-char)))))
	       (set! param-value-found #t)
	       (tilde-dispatch))
	      ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
	       (if modifier (format:error "misplaced modifier"))
	       (let ((num-str-beg (- format:pos 1))
		     (num-str-end format:pos))
		 (do ((ch (peek-next-char) (peek-next-char)))
		     ((not (char-numeric? ch)))
		   (next-char)
		   (set! num-str-end (+ 1 num-str-end)))
		 (set! params
		       (append params
			       (list (string->number
				      (substring format-string
						 num-str-beg
						 num-str-end))))))
	       (set! param-value-found #t)
	       (tilde-dispatch))
	      ((#\V)			; Variable parameter from next argum.
	       (if modifier (format:error "misplaced modifier"))
	       (set! params (append params (list (next-arg))))
	       (set! param-value-found #t)
	       (tilde-dispatch))
	      ((#\#)			; Parameter is number of remaining args
	       (if modifier (format:error "misplaced modifier"))
	       (set! params (append params (list (length (rest-args)))))
	       (set! param-value-found #t)
	       (tilde-dispatch))
	      ((#\,)			; Parameter separators
	       (if modifier (format:error "misplaced modifier"))
	       (if (not param-value-found)
		   (set! params (append params '(#f)))) ; append empty paramtr
	       (set! param-value-found #f)
	       (tilde-dispatch))
	      ((#\Q)			; Inquiry messages
	       (if (eq? modifier 'colon)
		   (format:out-str format:version)
		   (let ((nl (string #\newline)))
		     (format:out-str
		      (string-append
		       "SLIB Common LISP format version " format:version nl
		       "  (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
		       "  please send bug reports to `[e-mail]'"
		       nl))))
	       (anychar-dispatch))
	      (else			; Unknown tilde directive
	       (format:error "unknown control character `~c'"
		      (string-ref format-string (- format:pos 1))))))
	   (else (anychar-dispatch)))))) ; in case of conditional

    (set! format:pos 0)
    (set! format:arg-pos 0)
    (anychar-dispatch)			; start the formatting
    (set! format:pos recursive-pos-save)
    arg-pos))				; return the position in the arg. list

;; format:obj->str returns a R4RS representation as a string of an arbitrary
;; scheme object.
;; First parameter is the object, second parameter is a boolean if the
;; representation should be slashified as `write' does.
;; It uses format:char->str which converts a character into
;; a slashified string as `write' does and which is implementation dependent.
;; It uses format:iobj->str to print out internal objects as
;; quoted strings so that the output can always be processed by (read)

(define (format:obj->str obj slashify)
  (define (obj->str obj slashify visited)
    (if (memq obj (cdr visited))
	(let ((n (- (list-index (cdr visited) (cdr obj)))))
	  (string-append "#" (number->string n) "#"))
	(cond
	 ((string? obj)
	  (if slashify
	      (let ((obj-len (string-length obj)))
		(string-append
		 "\""
		 (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
		   (if (= j obj-len)
		       (string-append (substring obj i j) "\"")
		       (let ((c (string-ref obj j)))
			 (if (or (char=? c #\\)
				 (char=? c #\"))
			     (string-append (substring obj i j) "\\"
					    (loop j (+ j 1)))
			     (loop i (+ j 1))))))))
	      obj))
   
	 ((boolean? obj) (if obj "#t" "#f"))
   
	 ((number? obj) (number->string obj))

	 ((symbol? obj) 
	  (if format:symbol-case-conv
	      (format:symbol-case-conv (symbol->string obj))
	      (symbol->string obj)))
   
	 ((char? obj)
	  (if slashify
	      (format:char->str obj)
	      (string obj)))
   
	 ((null? obj) "()")

	 ((input-port? obj)
	  (format:iobj->str obj))
   
	 ((output-port? obj)
	  (format:iobj->str obj))
     
	 ((pair? obj)
	  (string-append "("
			 (let loop ((obj-list obj)
				    (visited visited)
				    (offset 0)
				    (prefix ""))
			   (cond ((null? (cdr obj-list))
				  (string-append
				   prefix
				   (obj->str (car obj-list)
					     #t
					     (cons (car obj-list) visited))))
				 ((memq (cdr obj-list) visited)
				  (string-append
				   prefix
				   (obj->str (car obj-list)
					     #t
					     (cons (car obj-list) visited))
				   " . #"
				   (number->string
				    (- offset
				       (list-index visited (cdr obj-list))))
				   "#"))
				 ((pair? (cdr obj-list))
				  (loop (cdr obj-list)
					(cons (cdr obj-list) visited)
					(+ 1 offset)
					(string-append
					 prefix