code:
;;;; 	Copyright (C) 1996, 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

;;; Commentary:

;; This module is documented in the Guile Reference Manual.
;; Briefly, these are exported:
;;  procedures: expect-select, expect-regexec
;;   variables: expect-port, expect-timeout, expect-timeout-proc,
;;              expect-eof-proc, expect-char-proc,
;;              expect-strings-compile-flags, expect-strings-exec-flags,
;;      macros: expect, expect-strings

;;; Code:

(define-module (ice-9 expect)
  :use-module (ice-9 regex)
  :export-syntax (expect expect-strings)
  :export (expect-port expect-timeout expect-timeout-proc
	   expect-eof-proc expect-char-proc expect-strings-compile-flags
	   expect-strings-exec-flags expect-select expect-regexec))

;;; Expect: a macro for selecting actions based on what it reads from a port.
;;; The idea is from Don Libes' expect based on Tcl.
;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.

(define expect-port #f)
(define expect-timeout #f)
(define expect-timeout-proc #f)
(define expect-eof-proc #f)
(define expect-char-proc #f)

;;; expect: each test is a procedure which is applied to the accumulating
;;; string.
(defmacro expect clauses
  (let ((s (gensym))
	(c (gensym))
	(port (gensym))
	(timeout (gensym)))
    `(let ((,s "")
	   (,port (or expect-port (current-input-port)))
	   ;; when timeout occurs, in floating point seconds.
	   (,timeout (if expect-timeout
			 (let* ((secs-usecs (gettimeofday)))
			   (+ (car secs-usecs)
			      expect-timeout
			      (/ (cdr secs-usecs)
				 1000000))) ; one million.
			 #f)))
       (let next-char ()
	 (if (and expect-timeout
		  (not (expect-select ,port ,timeout)))
	     (if expect-timeout-proc
		 (expect-timeout-proc ,s)
		 #f)
	     (let ((,c (read-char ,port)))
	       (if expect-char-proc
		   (expect-char-proc ,c))
	       (if (not (eof-object? ,c))
		   (set! ,s (string-append ,s (string ,c))))
	       (cond
		;; this expands to clauses where the car invokes the
		;; match proc and the cdr is the return value from expect
		;; if the proc matched.
		,@(let next-expr ((tests (map car clauses))
				  (exprs (map cdr clauses))
				  (body '()))
		    (cond
		     ((null? tests)
		      (reverse body))
		     (else
		      (next-expr
		       (cdr tests)
		       (cdr exprs)
		       (cons
			`((,(car tests) ,s (eof-object? ,c))
			  ,@(cond ((null? (car exprs))
				   '())
				  ((eq? (caar exprs) '=>)
				   (if (not (= (length (car exprs))
					       2))
				       (scm-error 'misc-error
						  "expect"
						  "bad recipient: ~S"
						  (list (car exprs))
						  #f)
				       `((apply ,(cadar exprs)
						(,(car tests) ,s ,port)))))
				  (else
				   (car exprs))))
			body)))))
		;; if none of the clauses matched the current string.
		(else (cond ((eof-object? ,c)
			     (if expect-eof-proc
				 (expect-eof-proc ,s)
				 #f))
			    (else
			     (next-char)))))))))))

(define expect-strings-compile-flags regexp/newline)
(define expect-strings-exec-flags regexp/noteol)

;;; the regexec front-end to expect:
;;; each test must evaluate to a regular expression.
(defmacro expect-strings clauses
  `(let ,@(let next-test ((tests (map car clauses))
			  (exprs (map cdr clauses))
			  (defs '())
			  (body '()))
	    (cond ((null? tests)
		   (list (reverse defs) `(expect ,@(reverse body))))
		  (else
		   (let ((rxname (gensym)))
		     (next-test (cdr tests)
				(cdr exprs)
				(cons `(,rxname (make-regexp
						 ,(car tests)
						 expect-strings-compile-flags))
				      defs)
				(cons `((lambda (s eof?)
					  (expect-regexec ,rxname s eof?))
					,@(car exprs))
				      body))))))))

;;; simplified select: returns #t if input is waiting or #f if timed out or
;;; select was interrupted by a signal.
;;; timeout is an absolute time in floating point seconds.
(define (expect-select port timeout)
  (let* ((secs-usecs (gettimeofday))
	 (relative (- timeout
		      (car secs-usecs)
		      (/ (cdr secs-usecs)
			 1000000))))	; one million.
    (and (> relative 0)
	 (pair? (car (select (list port) '() '()
			     relative))))))

;;; match a string against a regexp, returning a list of strings (required
;;; by the => syntax) or #f.  called once each time a character is added
;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
(define (expect-regexec rx s eof?)
  ;; if expect-strings-exec-flags contains regexp/noteol,
  ;; remove it for the eof test.
  (let* ((flags (if (and eof?
			 (logand expect-strings-exec-flags regexp/noteol))
		    (logxor expect-strings-exec-flags regexp/noteol)
		    expect-strings-exec-flags))
	 (match (regexp-exec rx s 0 flags)))
    (if match
	(do ((i (- (match:count match) 1) (- i 1))
	     (result '() (cons (match:substring match i) result)))
	    ((< i 0) result))
	#f)))

;;; expect.scm ends here


code:
;;;; "format.scm" Common LISP text output formatter for SLIB
;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
;;; 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 bug-guile@gnu.org.
;; 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 truncated-print)
  :replace (format)
  :export (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 . args)
  (letrec
      ((format:version "3.0")
       (format:port #f)			; curr. format output port
       (format:output-col 0)		; curr. format output tty column
       (format:flush-output #f)		; flush output at end of formatting
       (format:case-conversion #f)
       (format:args #f)
       (format:pos 0)			; curr. format string parsing position
       (format:arg-pos 0)		; curr. format argument position
					; this is global for error presentation

       ;; format string and char output routines on format:port

       (format:out-str
	(lambda (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)))))

       (format:out-char
	(lambda (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)))

       (format:out-substr
	(lambda (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 i)))))

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

       (format:out-fill
	(lambda (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

       (format:error
	(lambda args		; never returns!
	  (let ((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)
	    (format:abort))))

       (format:intern-error
	(lambda 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)))

       (format:error-save #f)

       (format:format
	(lambda 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)))))))

       (format:out                              ; the output handler for a port
	(lambda (port fmt args)
	  (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-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)))))

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

       (format:format-work ; does the formatting work
	(lambda (format-string arglist)
	  (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
			     (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)			; Structured print
                       (let ((width (if (one-positive-integer? params)
                                        (car params)
                                        79)))
                         (case modifier
                           ((at)
                            (format:out-str
                             (with-output-to-string
                               (lambda ()
                                 (truncated-print (next-arg)
                                                  #:width width)))))
                           ((colon-at)
                            (format:out-str
                             (with-output-to-string
                               (lambda ()
                                 (truncated-print (next-arg)
                                                  #:width
                                                  (max (- width
                                                          format:output-col)
                                                       1))))))
                           ((colon)
                            (format:error "illegal modifier in ~~?"))
                           (else
                            (pretty-print (next-arg) format:port
                                          #:width width)
                            (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")))
		       (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)
					   (and max-iterations
						(>= 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)
					   (and max-iterations
						(>= 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)
						 (and max-iterations
						      (>= 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)
						 (and max-iterations
						      (>= 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 param-value-found (format:error "misplaced '#'"))
		       (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 `lutzeb@cs.tu-berlin.de'"
			       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

       ;; when format:read-proof is true, format:obj->str will wrap
       ;; result strings starting with "#<" in an extra pair of double
       ;; quotes.

       (format:read-proof #f)

       ;; format:obj->str returns a R4RS representation as a string of
       ;; an arbitrary scheme object.

       (format:obj->str
	(lambda (obj slashify)
	  (let ((res (if slashify
			 (object->string obj)
			 (with-output-to-string (lambda () (display obj))))))
	    (if (and format:read-proof (string-prefix? "#<" res))
		(object->string res)
		res))))

       ;; format:char->str converts a character into a slashified string as
       ;; done by `write'. The procedure is dependent on the integer
       ;; representation of characters and assumes a character number according to
       ;; the ASCII character set.

       (format:char->str
	(lambda (ch)
	  (let ((int-rep (char->integer ch)))
	    (if (< int-rep 0)			; if chars are [-128...+127]
		(set! int-rep (+ int-rep 256)))
	    (string-append
	     "#\\"
	     (cond
	      ((char=? ch #\newline) "newline")
	      ((and (>= int-rep 0) (<= int-rep 32))
	       (vector-ref format:ascii-non-printable-charnames int-rep))
	      ((= int-rep 127) "del")
	      ((>= int-rep 128)		; octal representation
	       (if format:radix-pref
		   (let ((s (number->string int-rep 8)))
		     (substring s 2 (string-length s)))
		   (number->string int-rep 8)))
	      (else (string ch)))))))

       (format:space-ch (char->integer #\space))
       (format:zero-ch (char->integer #\0))

       (format:par
	(lambda (pars length index default name)
	  (if (> length index)
	      (let ((par (list-ref pars index)))
		(if par
		    (if name
			(if (< par 0)
			    (format:error
			     "~s parameter must be a positive integer" name)
			    par)
			par)
		    default))
	      default)))

       (format:out-obj-padded
	(lambda (pad-left obj slashify pars)
	       (if (null? pars)
		   (format:out-str (format:obj->str obj slashify))
		   (let ((l (length pars)))
		     (let ((mincol (format:par pars l 0 0 "mincol"))
			   (colinc (format:par pars l 1 1 "colinc"))
			   (minpad (format:par pars l 2 0 "minpad"))
			   (padchar (integer->char
				     (format:par pars l 3 format:space-ch #f)))
			   (objstr (format:obj->str obj slashify)))
		       (if (not pad-left)
			   (format:out-str objstr))
		       (do ((objstr-len (string-length objstr))
			    (i minpad (+ i colinc)))
			   ((>= (+ objstr-len i) mincol)
			    (format:out-fill i padchar)))
		       (if pad-left
			   (format:out-str objstr)))))))

       (format:out-num-padded
	(lambda (modifier number pars radix)
	  (if (not (integer? number)) (format:error "argument not an integer"))
	  (let ((numstr (number->string number radix)))
	    (if (and format:radix-pref (not (= radix 10)))
		(set! numstr (substring numstr 2 (string-length numstr))))
	    (if (and (null? pars) (not modifier))
		(format:out-str numstr)
		(let ((l (length pars))
		      (numstr-len (string-length numstr)))
		  (let ((mincol (format:par pars l 0 #f "mincol"))
			(padchar (integer->char
				  (format:par pars l 1 format:space-ch #f)))
			(commachar (integer->char
				    (format:par pars l 2 (char->integer #\,) #f)))
			(commawidth (format:par pars l 3 3 "commawidth")))
		    (if mincol
			(let ((numlen numstr-len)) ; calc. the output len of number
			  (if (and (memq modifier '(at colon-at)) (>= number 0))
			      (set! numlen (+ numlen 1)))
			  (if (memq modifier '(colon colon-at))
			      (set! numlen (+ (quotient (- numstr-len
							   (if (< number 0) 2 1))
							commawidth)
					      numlen)))
			  (if (> mincol numlen)
			      (format:out-fill (- mincol numlen) padchar))))
		    (if (and (memq modifier '(at colon-at))
			     (>= number 0))
			(format:out-char #\+))
		    (if (memq modifier '(colon colon-at)) ; insert comma character
			(let ((start (remainder numstr-len commawidth))
			      (ns (if (< number 0) 1 0)))
			  (format:out-substr numstr 0 start)
			  (do ((i start (+ i commawidth)))
			      ((>= i numstr-len))
			    (if (> i ns)
				(format:out-char commachar))
			    (format:out-substr numstr i (+ i commawidth))))
			(format:out-str numstr))))))))

       (format:tabulate
	(lambda (modifier pars)
	  (let ((l (length pars)))
	    (let ((colnum (format:par pars l 0 1 "colnum"))
		  (colinc (format:par pars l 1 1 "colinc"))
		  (padch (integer->char (format:par pars l 2 format:space-ch #f))))
	      (case modifier
		((colon colon-at)
		 (format:error "unsupported modifier for ~~t"))
		((at)				; relative tabulation
		 (format:out-fill
		  (if (= colinc 0)
		      colnum			; colnum = colrel
		      (do ((c 0 (+ c colinc))
			   (col (+ format:output-col colnum)))
			  ((>= c col)
			   (- c format:output-col))))
		  padch))
		(else				; absolute tabulation
		 (format:out-fill
		  (cond
		   ((< format:output-col colnum)
		    (- colnum format:output-col))
		   ((= colinc 0)
		    0)
		   (else
		    (do ((c colnum (+ c colinc)))
			((>= c format:output-col)
			 (- c format:output-col)))))
		  padch)))))))

       ;; roman numerals (from dorai@cs.rice.edu).

       (format:roman-alist
	'((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
	  (10 #\X) (5 #\V) (1 #\I)))

       (format:roman-boundary-values
	'(100 100 10 10 1 1 #f))

       (format:num->old-roman
	(lambda (n)
	  (if (and (integer? n) (>= n 1))
	      (let loop ((n n)
			 (romans format:roman-alist)
			 (s '()))
		(if (null? romans) (list->string (reverse s))
		    (let ((roman-val (caar romans))
			  (roman-dgt (cadar romans)))
		      (do ((q (quotient n roman-val) (- q 1))
			   (s s (cons roman-dgt s)))
			  ((= q 0)
			   (loop (remainder n roman-val)
				 (cdr romans) s))))))
	      (format:error "only positive integers can be romanized"))))

       (format:num->roman
	(lambda (n)
	  (if (and (integer? n) (> n 0))
	      (let loop ((n n)
			 (romans format:roman-alist)
			 (boundaries format:roman-boundary-values)
			 (s '()))
		(if (null? romans)
		    (list->string (reverse s))
		    (let ((roman-val (caar romans))
			  (roman-dgt (cadar romans))
			  (bdry (car boundaries)))
		      (let loop2 ((q (quotient n roman-val))
				  (r (remainder n roman-val))
				  (s s))
			(if (= q 0)
			    (if (and bdry (>= r (- roman-val bdry)))
				(loop (remainder r bdry) (cdr romans)
				      (cdr boundaries)
				      (cons roman-dgt
					    (append
					     (cdr (assv bdry romans))
					     s)))
				(loop r (cdr romans) (cdr boundaries) s))
			    (loop2 (- q 1) r (cons roman-dgt s)))))))
	      (format:error "only positive integers can be romanized"))))

       ;; cardinals & ordinals (from dorai@cs.rice.edu)

       (format:cardinal-ones-list
	'(#f "one" "two" "three" "four" "five"
	     "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
	     "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
	     "nineteen"))

       (format:cardinal-tens-list
	'(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
	     "ninety"))

       (format:num->cardinal999
	(lambda (n)
					;this procedure is inspired by the Bruno Haible's CLisp
					;function format-small-cardinal, which converts numbers
					;in the range 1 to 999, and is used for converting each
					;thousand-block in a larger number
	  (let* ((hundreds (quotient n 100))
		 (tens+ones (remainder n 100))
		 (tens (quotient tens+ones 10))
		 (ones (remainder tens+ones 10)))
	    (append
	     (if (> hundreds 0)
		 (append
		  (string->list
		   (list-ref format:cardinal-ones-list hundreds))
		  (string->list" hundred")
		  (if (> tens+ones 0) '(#\space) '()))
		 '())
	     (if (< tens+ones 20)
		 (if (> tens+ones 0)
		     (string->list
		      (list-ref format:cardinal-ones-list tens+ones))
		     '())
		 (append
		  (string->list
		   (list-ref format:cardinal-tens-list tens))
		  (if (> ones 0)
		      (cons #\-
			    (string->list
			     (list-ref format:cardinal-ones-list ones)))
		      '())))))))

       (format:cardinal-thousand-block-list
	'("" " thousand" " million" " billion" " trillion" " quadrillion"
	  " quintillion" " sextillion" " septillion" " octillion" " nonillion"
	  " decillion" " undecillion" " duodecillion" " tredecillion"
	  " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
	  " octodecillion" " novemdecillion" " vigintillion"))

       (format:num->cardinal
	(lambda (n)
	  (cond ((not (integer? n))
		 (format:error
		  "only integers can be converted to English cardinals"))
		((= n 0) "zero")
		((< n 0) (string-append "minus " (format:num->cardinal (- n))))
		(else
		 (let ((power3-word-limit
			(length format:cardinal-thousand-block-list)))
		   (let loop ((n n)
			      (power3 0)
			      (s '()))
		     (if (= n 0)
			 (list->string s)
			 (let ((n-before-block (quotient n 1000))
			       (n-after-block (remainder n 1000)))
			   (loop n-before-block
				 (+ power3 1)
				 (if (> n-after-block 0)
				     (append
				      (if (> n-before-block 0)
					  (string->list ", ") '())
				      (format:num->cardinal999 n-after-block)
				      (if (< power3 power3-word-limit)
					  (string->list
					   (list-ref
					    format:cardinal-thousand-block-list
					    power3))
					  (append
					   (string->list " times ten to the ")
					   (string->list
					    (format:num->ordinal
					     (* power3 3)))
					   (string->list " power")))
				      s)
				     s))))))))))

       (format:ordinal-ones-list
	'(#f "first" "second" "third" "fourth" "fifth"
	     "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
	     "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
	     "eighteenth" "nineteenth"))

       (format:ordinal-tens-list
	'(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
	     "seventieth" "eightieth" "ninetieth"))

       (format:num->ordinal
	(lambda (n)
	  (cond ((not (integer? n))
		 (format:error
		  "only integers can be converted to English ordinals"))
		((= n 0) "zeroth")
		((< n 0) (string-append "minus " (format:num->ordinal (- n))))
		(else
		 (let ((hundreds (quotient n 100))
		       (tens+ones (remainder n 100)))
		   (string-append
		    (if (> hundreds 0)
			(string-append
			 (format:num->cardinal (* hundreds 100))
			 (if (= tens+ones 0) "th" " "))
			"")
		    (if (= tens+ones 0) ""
			(if (< tens+ones 20)
			    (list-ref format:ordinal-ones-list tens+ones)
			    (let ((tens (quotient tens+ones 10))
				  (ones (remainder tens+ones 10)))
			      (if (= ones 0)
				  (list-ref format:ordinal-tens-list tens)
				  (string-append
				   (list-ref format:cardinal-tens-list tens)
				   "-"
				   (list-ref format:ordinal-ones-list ones))))
			    ))))))))

       ;; format inf and nan.

       (format:out-inf-nan
	(lambda (number width digits edigits overch padch)
	  ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
	  ;; "+nan.0", suitably justified in their field.  We insist on
	  ;; printing this exact form so that the numbers can be read back in.

	  (let* ((str (number->string number))
		 (len (string-length str))
		 (dot (string-index str #\.))
		 (digits (+ (or digits 0)
			    (if edigits (+ edigits 2) 0))))
	    (if (and width overch (< width len))
		(format:out-fill width (integer->char overch))
		(let* ((leftpad (if width
				    (max (- width (max len (+ dot 1 digits))) 0)
				    0))
		       (rightpad (if width
				     (max (- width leftpad len) 0)
				     0))
		       (padch (integer->char (or padch format:space-ch))))
		  (format:out-fill leftpad padch)
		  (format:out-str str)
		  (format:out-fill rightpad padch))))))

       ;; format fixed flonums (~F)

       (format:out-fixed
	(lambda (modifier number pars)
	  (if (not (or (number? number) (string? number)))
	      (format:error "argument is not a number or a number string"))

	  (let ((l (length pars)))
	    (let ((width (format:par pars l 0 #f "width"))
		  (digits (format:par pars l 1 #f "digits"))
		  (scale (format:par pars l 2 0 #f))
		  (overch (format:par pars l 3 #f #f))
		  (padch (format:par pars l 4 format:space-ch #f)))

	      (cond
	       ((or (inf? number) (nan? number))
		(format:out-inf-nan number width digits #f overch padch))

	       (digits
		(format:parse-float number #t scale)
		(if (<= (- format:fn-len format:fn-dot) digits)
		    (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
		    (format:fn-round digits))
		(if width
		    (let ((numlen (+ format:fn-len 1)))
		      (if (or (not format:fn-pos?) (eq? modifier 'at))
			  (set! numlen (+ numlen 1)))
		      (if (and (= format:fn-dot 0) (> width (+ digits 1)))
			  (set! numlen (+ numlen 1)))
		      (if (< numlen width)
			  (format:out-fill (- width numlen) (integer->char padch)))
		      (if (and overch (> numlen width))
			  (format:out-fill width (integer->char overch))
			  (format:fn-out modifier (> width (+ digits 1)))))
		    (format:fn-out modifier #t)))

	       (else
		(format:parse-float number #t scale)
		(format:fn-strip)
		(if width
		    (let ((numlen (+ format:fn-len 1)))
		      (if (or (not format:fn-pos?) (eq? modifier 'at))
			  (set! numlen (+ numlen 1)))
		      (if (= format:fn-dot 0)
			  (set! numlen (+ numlen 1)))
		      (if (< numlen width)
			  (format:out-fill (- width numlen) (integer->char padch)))
		      (if (> numlen width)	; adjust precision if possible
			  (let ((dot-index (- numlen
					      (- format:fn-len format:fn-dot))))
			    (if (> dot-index width)
				(if overch	; numstr too big for required width
				    (format:out-fill width (integer->char overch))
				    (format:fn-out modifier #t))
				(begin
				  (format:fn-round (- width dot-index))
				  (format:fn-out modifier #t))))
			  (format:fn-out modifier #t)))
		    (format:fn-out modifier #t))))))))

       ;; format exponential flonums (~E)

       (format:out-expon
	(lambda (modifier number pars)
	  (if (not (or (number? number) (string? number)))
	      (format:error "argument is not a number"))

	  (let ((l (length pars)))
	    (let ((width (format:par pars l 0 #f "width"))
		  (digits (format:par pars l 1 #f "digits"))
		  (edigits (format:par pars l 2 #f "exponent digits"))
		  (scale (format:par pars l 3 1 #f))
		  (overch (format:par pars l 4 #f #f))
		  (padch (format:par pars l 5 format:space-ch #f))
		  (expch (format:par pars l 6 #f #f)))

	      (cond
	       ((or (inf? number) (nan? number))
		(format:out-inf-nan number width digits edigits overch padch))

	       (digits				; fixed precision

		(let ((digits (if (> scale 0)
				  (if (< scale (+ digits 2))
				      (+ (- digits scale) 1)
				      0)
				  digits)))
		  (format:parse-float number #f scale)
		  (if (<= (- format:fn-len format:fn-dot) digits)
		      (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
		      (format:fn-round digits))
		  (if width
		      (if (and edigits overch (> format:en-len edigits))
			  (format:out-fill width (integer->char overch))
			  (let ((numlen (+ format:fn-len 3))) ; .E+
			    (if (or (not format:fn-pos?) (eq? modifier 'at))
				(set! numlen (+ numlen 1)))
			    (if (and (= format:fn-dot 0) (> width (+ digits 1)))
				(set! numlen (+ numlen 1)))
			    (set! numlen
				  (+ numlen
				     (if (and edigits (>= edigits format:en-len))
					 edigits
					 format:en-len)))
			    (if (< numlen width)
				(format:out-fill (- width numlen)
						 (integer->char padch)))
			    (if (and overch (> numlen width))
				(format:out-fill width (integer->char overch))
				(begin
				  (format:fn-out modifier (> width (- numlen 1)))
				  (format:en-out edigits expch)))))
		      (begin
			(format:fn-out modifier #t)
			(format:en-out edigits expch)))))

	       (else
		(format:parse-float number #f scale)
		(format:fn-strip)
		(if width
		    (if (and edigits overch (> format:en-len edigits))
			(format:out-fill width (integer->char overch))
			(let ((numlen (+ format:fn-len 3))) ; .E+
			  (if (or (not format:fn-pos?) (eq? modifier 'at))
			      (set! numlen (+ numlen 1)))
			  (if (= format:fn-dot 0)
			      (set! numlen (+ numlen 1)))
			  (set! numlen
				(+ numlen
				   (if (and edigits (>= edigits format:en-len))
				       edigits
				       format:en-len)))
			  (if (< numlen width)
			      (format:out-fill (- width numlen)
					       (integer->char padch)))
			  (if (> numlen width) ; adjust precision if possible
			      (let ((f (- format:fn-len format:fn-dot))) ; fract len
				(if (> (- numlen f) width)
				    (if overch ; numstr too big for required width
					(format:out-fill width
							 (integer->char overch))
					(begin
					  (format:fn-out modifier #t)
					  (format:en-out edigits expch)))
				    (begin
				      (format:fn-round (+ (- f numlen) width))
				      (format:fn-out modifier #t)
				      (format:en-out edigits expch))))
			      (begin
				(format:fn-out modifier #t)
				(format:en-out edigits expch)))))
		    (begin
		      (format:fn-out modifier #t)
		      (format:en-out edigits expch)))))))))

       ;; format general flonums (~G)

       (format:out-general
	(lambda (modifier number pars)
	  (if (not (or (number? number) (string? number)))
	      (format:error "argument is not a number or a number string"))

	  (let ((l (length pars)))
	    (let ((width (if (> l 0) (list-ref pars 0) #f))
		  (digits (if (> l 1) (list-ref pars 1) #f))
		  (edigits (if (> l 2) (list-ref pars 2) #f))
		  (overch (if (> l 4) (list-ref pars 4) #f))
		  (padch (if (> l 5) (list-ref pars 5) #f)))
	      (cond
	       ((or (inf? number) (nan? number))
		;; FIXME: this isn't right.
		(format:out-inf-nan number width digits edigits overch padch))
	       (else
		(format:parse-float number #t 0)
		(format:fn-strip)
		(let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
		       (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
		       (n (if (= format:fn-dot 0)	; number less than (abs 1.0) ?
			      (- (format:fn-zlead))
			      format:fn-dot))
		       (d (if digits
			      digits
			      (max format:fn-len (min n 7)))) ; q = format:fn-len
		       (dd (- d n)))
		  (if (<= 0 dd d)
		      (begin
			(format:out-fixed modifier number (list ww dd #f overch padch))
			(format:out-fill ee #\space)) ;~@T not implemented yet
		      (format:out-expon modifier number pars)))))))))

       ;; format dollar flonums (~$)

       (format:out-dollar
	(lambda (modifier number pars)
	  (if (not (or (number? number) (string? number)))
	      (format:error "argument is not a number or a number string"))

	  (let ((l (length pars)))
	    (let ((digits (format:par pars l 0 2 "digits"))
		  (mindig (format:par pars l 1 1 "mindig"))
		  (width (format:par pars l 2 0 "width"))
		  (padch (format:par pars l 3 format:space-ch #f)))

	      (cond
	       ((or (inf? number) (nan? number))
		(format:out-inf-nan number width digits #f #f padch))

	       (else
		(format:parse-float number #t 0)
		(if (<= (- format:fn-len format:fn-dot) digits)
		    (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
		    (format:fn-round digits))
		(let ((numlen (+ format:fn-len 1)))
		  (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
		      (set! numlen (+ numlen 1)))
		  (if (and mindig (> mindig format:fn-dot))
		      (set! numlen (+ numlen (- mindig format:fn-dot))))
		  (if (and (= format:fn-dot 0) (not mindig))
		      (set! numlen (+ numlen 1)))
		  (if (< numlen width)
		      (case modifier
			((colon)
			 (if (not format:fn-pos?)
			     (format:out-char #\-))
			 (format:out-fill (- width numlen) (integer->char padch)))
			((at)
			 (format:out-fill (- width numlen) (integer->char padch))
			 (format:out-char (if format:fn-pos? #\+ #\-)))
			((colon-at)
			 (format:out-char (if format:fn-pos? #\+ #\-))
			 (format:out-fill (- width numlen) (integer->char padch)))
			(else
			 (format:out-fill (- width numlen) (integer->char padch))
			 (if (not format:fn-pos?)
			     (format:out-char #\-))))
		      (if format:fn-pos?
			  (if (memq modifier '(at colon-at)) (format:out-char #\+))
			  (format:out-char #\-))))
		(if (and mindig (> mindig format:fn-dot))
		    (format:out-fill (- mindig format:fn-dot) #\0))
		(if (and (= format:fn-dot 0) (not mindig))
		    (format:out-char #\0))
		(format:out-substr format:fn-str 0 format:fn-dot)
		(format:out-char #\.)
		(format:out-substr format:fn-str format:fn-dot format:fn-len)))))))

					; the flonum buffers

       (format:fn-max 400)		; max. number of number digits
       (format:fn-str #f) ; number buffer
       (format:fn-len 0)		; digit length of number
       (format:fn-dot #f)		; dot position of number
       (format:fn-pos? #t)		; number positive?
       (format:en-max 10)		; max. number of exponent digits
       (format:en-str #f) ; exponent buffer
       (format:en-len 0)		; digit length of exponent
       (format:en-pos? #t)		; exponent positive?

       (format:parse-float
	(lambda (num fixed? scale)
          (let ((num-str (if (string? num)
                             num
                             (number->string (exact->inexact num)))))
            (set! format:fn-pos? #t)
            (set! format:fn-len 0)
            (set! format:fn-dot #f)
            (set! format:en-pos? #t)
            (set! format:en-len 0)
            (do ((i 0 (+ i 1))
                 (left-zeros 0)
                 (mantissa? #t)
                 (all-zeros? #t)
                 (num-len (string-length num-str))
                 (c #f))                ; current exam. character in num-str
                ((= i num-len)
                 (if (not format:fn-dot)
                     (set! format:fn-dot format:fn-len))

                 (if all-zeros?
                     (begin
                       (set! left-zeros 0)
                       (set! format:fn-dot 0)
                       (set! format:fn-len 1)))

                 ;; now format the parsed values according to format's need

                 (if fixed?

                     (begin             ; fixed format m.nnn or .nnn
                       (if (and (> left-zeros 0) (> format:fn-dot 0))
                           (if (> format:fn-dot left-zeros)
                               (begin   ; norm 0{0}nn.mm to nn.mm
                                 (format:fn-shiftleft left-zeros)
                                 (set! format:fn-dot (- format:fn-dot left-zeros))
                                 (set! left-zeros 0))
                               (begin   ; normalize 0{0}.nnn to .nnn
                                 (format:fn-shiftleft format:fn-dot)
                                 (set! left-zeros (- left-zeros format:fn-dot))
                                 (set! format:fn-dot 0))))
                       (if (or (not (= scale 0)) (> format:en-len 0))
                           (let ((shift (+ scale (format:en-int))))
                             (cond
                              (all-zeros? #t)
                              ((> (+ format:fn-dot shift) format:fn-len)
                               (format:fn-zfill
                                #f (- shift (- format:fn-len format:fn-dot)))
                               (set! format:fn-dot format:fn-len))
                              ((< (+ format:fn-dot shift) 0)
                               (format:fn-zfill #t (- (- shift) format:fn-dot))
                               (set! format:fn-dot 0))
                              (else
                               (if (> left-zeros 0)
                                   (if (<= left-zeros shift) ; shift always > 0 here
                                       (format:fn-shiftleft shift) ; shift out 0s
                                       (begin
                                         (format:fn-shiftleft left-zeros)
                                         (set! format:fn-dot (- shift left-zeros))))
                                   (set! format:fn-dot (+ format:fn-dot shift))))))))

                     (let ((negexp      ; expon format m.nnnEee
                            (if (> left-zeros 0)
                                (- left-zeros format:fn-dot -1)
                                (if (= format:fn-dot 0) 1 0))))
                       (if (> left-zeros 0)
                           (begin       ; normalize 0{0}.nnn to n.nn
                             (format:fn-shiftleft left-zeros)
                             (set! format:fn-dot 1))
                           (if (= format:fn-dot 0)
                               (set! format:fn-dot 1)))
                       (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
                                         negexp))
                       (cond
                        (all-zeros?
                         (format:en-set 0)
                         (set! format:fn-dot 1))
                        ((< scale 0)    ; leading zero
                         (format:fn-zfill #t (- scale))
                         (set! format:fn-dot 0))
                        ((> scale format:fn-dot)
                         (format:fn-zfill #f (- scale format:fn-dot))
                         (set! format:fn-dot scale))
                        (else
                         (set! format:fn-dot scale)))))
                 #t)

              ;; do body
              (set! c (string-ref num-str i)) ; parse the output of number->string
              (cond                           ; which can be any valid number
               ((char-numeric? c)             ; representation of R4RS except
                (if mantissa?                 ; complex numbers
                    (begin
                      (if (char=? c #\0)
                          (if all-zeros?
                              (set! left-zeros (+ left-zeros 1)))
                          (begin
                            (set! all-zeros? #f)))
                      (string-set! format:fn-str format:fn-len c)
                      (set! format:fn-len (+ format:fn-len 1)))
                    (begin
                      (string-set! format:en-str format:en-len c)
                      (set! format:en-len (+ format:en-len 1)))))
               ((or (char=? c #\-) (char=? c #\+))
                (if mantissa?
                    (set! format:fn-pos? (char=? c #\+))
                    (set! format:en-pos? (char=? c #\+))))
               ((char=? c #\.)
                (set! format:fn-dot format:fn-len))
               ((char=? c #\e)
                (set! mantissa? #f))
               ((char=? c #\E)
                (set! mantissa? #f))
               ((char-whitespace? c) #t)
               ((char=? c #\d) #t)      ; decimal radix prefix
               ((char=? c #\#) #t)
               (else
                (format:error "illegal character `~c' in number->string" c)))))))

       (format:en-int
	(lambda ()			; convert exponent string to integer
	  (if (= format:en-len 0)
	      0
	      (do ((i 0 (+ i 1))
		   (n 0))
		  ((= i format:en-len)
		   (if format:en-pos?
		       n
		       (- n)))
		(set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
				       format:zero-ch)))))))

       (format:en-set          ; set exponent string number
	(lambda (en)
	  (set! format:en-len 0)
	  (set! format:en-pos? (>= en 0))
	  (let ((en-str (number->string en)))
	    (do ((i 0 (+ i 1))
		 (en-len (string-length en-str))
		 (c #f))
		((= i en-len))
	      (set! c (string-ref en-str i))
	      (if (char-numeric? c)
		  (begin
		    (string-set! format:en-str format:en-len c)
		    (set! format:en-len (+ format:en-len 1))))))))

       (format:fn-zfill	; fill current number string with 0s
	(lambda (left? n)
	  (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
	      (format:error "number is too long to format (enlarge format:fn-max)"))
	  (set! format:fn-len (+ format:fn-len n))
	  (if left?
	      (do ((i format:fn-len (- i 1)))	; fill n 0s to left
		  ((< i 0))
		(string-set! format:fn-str i
			     (if (< i n)
				 #\0
				 (string-ref format:fn-str (- i n)))))
	      (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
		  ((= i format:fn-len))
		(string-set! format:fn-str i #\0)))))

       (format:fn-shiftleft		; shift left current number n positions
	(lambda (n)
	  (if (> n format:fn-len)
	      (format:error "internal error in format:fn-shiftleft (~d,~d)"
			    n format:fn-len))
	  (do ((i n (+ i 1)))
	      ((= i format:fn-len)
	       (set! format:fn-len (- format:fn-len n)))
	    (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))))

       (format:fn-round	; round format:fn-str
	(lambda (digits)
	  (set! digits (+ digits format:fn-dot))
	  (do ((i digits (- i 1))		; "099",2 -> "10"
	       (c 5))				; "023",2 -> "02"
	      ((or (= c 0) (< i 0))		; "999",2 -> "100"
	       (if (= c 1)			; "005",2 -> "01"
		   (begin			; carry overflow
		     (set! format:fn-len digits)
		     (format:fn-zfill #t 1)	; add a 1 before fn-str
		     (string-set! format:fn-str 0 #\1)
		     (set! format:fn-dot (+ format:fn-dot 1)))
		   (set! format:fn-len digits)))
	    (set! c (+ (- (char->integer (string-ref format:fn-str i))
			  format:zero-ch) c))
	    (string-set! format:fn-str i (integer->char
					  (if (< c 10)
					      (+ c format:zero-ch)
					      (+ (- c 10) format:zero-ch))))
	    (set! c (if (< c 10) 0 1)))))

       (format:fn-out
	(lambda (modifier add-leading-zero?)
	  (if format:fn-pos?
	      (if (eq? modifier 'at)
		  (format:out-char #\+))
	      (format:out-char #\-))
	  (if (= format:fn-dot 0)
	      (if add-leading-zero?
		  (format:out-char #\0))
	      (format:out-substr format:fn-str 0 format:fn-dot))
	  (format:out-char #\.)
	  (format:out-substr format:fn-str format:fn-dot format:fn-len)))

       (format:en-out
	(lambda (edigits expch)
	  (format:out-char (if expch (integer->char expch) format:expch))
	  (format:out-char (if format:en-pos? #\+ #\-))
	  (if edigits
	      (if (< format:en-len edigits)
		  (format:out-fill (- edigits format:en-len) #\0)))
	  (format:out-substr format:en-str 0 format:en-len)))

       (format:fn-strip		; strip trailing zeros but one
	(lambda ()
	  (string-set! format:fn-str format:fn-len #\0)
	  (do ((i format:fn-len (- i 1)))
	      ((or (not (char=? (string-ref format:fn-str i) #\0))
		   (<= i format:fn-dot))
	       (set! format:fn-len (+ i 1))))))

       (format:fn-zlead		; count leading zeros
	(lambda ()
	  (do ((i 0 (+ i 1)))
	      ((or (= i format:fn-len)
		   (not (char=? (string-ref format:fn-str i) #\0)))
	       (if (= i format:fn-len)		; found a real zero
		   0
		   i)))))

;;; some global functions not found in SLIB

       (string-capitalize-first	; "hello" -> "Hello"
	(lambda (str)
	  (let ((cap-str (string-copy str))	; "hELLO" -> "Hello"
		(non-first-alpha #f)		; "*hello" -> "*Hello"
		(str-len (string-length str)))	; "hello you" -> "Hello you"
	    (do ((i 0 (+ i 1)))
		((= i str-len) cap-str)
	      (let ((c (string-ref str i)))
		(if (char-alphabetic? c)
		    (if non-first-alpha
			(string-set! cap-str i (char-downcase c))
			(begin
			  (set! non-first-alpha #t)
			  (string-set! cap-str i (char-upcase c))))))))))

       ;; Aborts the program when a formatting error occures. This is a null
       ;; argument closure to jump to the interpreters toplevel continuation.

       (format:abort (lambda () (error "error in format"))))

    (set! format:error-save format:error)
    (set! format:fn-str (make-string format:fn-max)) ; number buffer
    (set! format:en-str (make-string format:en-max)) ; exponent buffer
    (apply format:format args)))

;; Thanks to Shuji Narazaki
(module-set! the-root-module 'format format)

license: mit


code:
;;;; ftw.scm --- file system tree walk

;;;; 	Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Two procedures are provided: `ftw' and `nftw'.

;; NOTE: The following description was adapted from the GNU libc info page, w/
;; significant modifications for a more "Schemey" interface.  Most noticible
;; are the inlining of `struct FTW *' parameters `base' and `level' and the
;; omission of `descriptors' parameters.

;; * Types
;;
;;    The X/Open specification defines two procedures to process whole
;; hierarchies of directories and the contained files.  Both procedures
;; of this `ftw' family take as one of the arguments a callback procedure
;; which must be of these types.
;;
;;  - Data Type: __ftw_proc_t
;;           (lambda (filename statinfo flag) ...) => status
;;
;;      Type for callback procedures given to the `ftw' procedure.  The
;;      first parameter is a filename, the second parameter is the
;;      vector value as returned by calling `stat' on FILENAME.
;;
;;      The last parameter is a symbol giving more information about
;;      FILENAM.  It can have one of the following values:
;;
;;     `regular'
;;           The current item is a normal file or files which do not fit
;;           into one of the following categories.  This means
;;           especially special files, sockets etc.
;;
;;     `directory'
;;           The current item is a directory.
;;
;;     `invalid-stat'
;;           The `stat' call to fill the object pointed to by the second
;;           parameter failed and so the information is invalid.
;;
;;     `directory-not-readable'
;;           The item is a directory which cannot be read.
;;
;;     `symlink'
;;           The item is a symbolic link.  Since symbolic links are
;;           normally followed seeing this value in a `ftw' callback
;;           procedure means the referenced file does not exist.  The
;;           situation for `nftw' is different.
;;
;;  - Data Type: __nftw_proc_t
;;           (lambda (filename statinfo flag base level) ...) => status
;;
;;      The first three arguments have the same as for the
;;      `__ftw_proc_t' type.  A difference is that for the third
;;      argument some additional values are defined to allow finer
;;      differentiation:
;;
;;     `directory-processed'
;;           The current item is a directory and all subdirectories have
;;           already been visited and reported.  This flag is returned
;;           instead of `directory' if the `depth' flag is given to
;;           `nftw' (see below).
;;
;;     `stale-symlink'
;;           The current item is a stale symbolic link.  The file it
;;           points to does not exist.
;;
;;      The last two parameters are described below.  They contain
;;      information to help interpret FILENAME and give some information
;;      about current state of the traversal of the directory hierarchy.
;;
;;     `base'
;;           The value specifies which part of the filename argument
;;           given in the first parameter to the callback procedure is
;;           the name of the file.  The rest of the string is the path
;;           to locate the file.  This information is especially
;;           important if the `chdir' flag for `nftw' was set since then
;;           the current directory is the one the current item is found
;;           in.
;;
;;     `level'
;;           While processing the directory the procedures tracks how
;;           many directories have been examined to find the current
;;           item.  This nesting level is 0 for the item given starting
;;           item (file or directory) and is incremented by one for each
;;           entered directory.
;;
;; * Procedure: (ftw filename proc . options)
;;   Do a file system tree walk starting at FILENAME using PROC.
;;
;;   The `ftw' procedure calls the callback procedure given in the
;;   parameter PROC for every item which is found in the directory
;;   specified by FILENAME and all directories below.  The procedure
;;   follows symbolic links if necessary but does not process an item
;;   twice.  If FILENAME names no directory this item is the only
;;   object reported by calling the callback procedure.
;;
;;   The filename given to the callback procedure is constructed by
;;   taking the FILENAME parameter and appending the names of all
;;   passed directories and then the local file name.  So the
;;   callback procedure can use this parameter to access the file.
;;   Before the callback procedure is called `ftw' calls `stat' for
;;   this file and passes the information up to the callback
;;   procedure.  If this `stat' call was not successful the failure is
;;   indicated by setting the flag argument of the callback procedure
;;   to `invalid-stat'.  Otherwise the flag is set according to the
;;   description given in the description of `__ftw_proc_t' above.
;;
;;   The callback procedure is expected to return non-#f to indicate
;;   that no error occurred and the processing should be continued.
;;   If an error occurred in the callback procedure or the call to
;;   `ftw' shall return immediately the callback procedure can return
;;   #f.  This is the only correct way to stop the procedure.  The
;;   program must not use `throw' or similar techniques to continue
;;   the program in another place.  [Can we relax this? --ttn]
;;
;;   The return value of the `ftw' procedure is #t if all callback
;;   procedure calls returned #t and all actions performed by the
;;   `ftw' succeeded.  If some procedure call failed (other than
;;   calling `stat' on an item) the procedure returns #f.  If a
;;   callback procedure returns a value other than #t this value is
;;   returned as the return value of `ftw'.
;;
;; * Procedure: (nftw filename proc . control-flags)
;;   Do a new-style file system tree walk starting at FILENAME using PROC.
;;   Various optional CONTROL-FLAGS alter the default behavior.
;;
;;   The `nftw' procedures works like the `ftw' procedures.  It calls
;;   the callback procedure PROC for all items it finds in the
;;   directory FILENAME and below.
;;
;;   The differences are that for one the callback procedure is of a
;;   different type.  It takes also `base' and `level' parameters as
;;   described above.
;;
;;   The second difference is that `nftw' takes additional optional
;;   arguments which are zero or more of the following symbols:
;;
;;   physical'
;;        While traversing the directory symbolic links are not
;;        followed.  I.e., if this flag is given symbolic links are
;;        reported using the `symlink' value for the type parameter
;;        to the callback procedure.  Please note that if this flag is
;;        used the appearance of `symlink' in a callback procedure
;;        does not mean the referenced file does not exist.  To
;;        indicate this the extra value `stale-symlink' exists.
;;
;;   mount'
;;        The callback procedure is only called for items which are on
;;        the same mounted file system as the directory given as the
;;        FILENAME parameter to `nftw'.
;;
;;   chdir'
;;        If this flag is given the current working directory is
;;        changed to the directory containing the reported object
;;        before the callback procedure is called.
;;
;;   depth'
;;        If this option is given the procedure visits first all files
;;        and subdirectories before the callback procedure is called
;;        for the directory itself (depth-first processing).  This
;;        also means the type flag given to the callback procedure is
;;        `directory-processed' and not `directory'.
;;
;;   The return value is computed in the same way as for `ftw'.
;;   `nftw' returns #t if no failure occurred in `nftw' and all
;;   callback procedure call return values are also #t.  For internal
;;   errors such as memory problems the error `ftw-error' is thrown.
;;   If the return value of a callback invocation is not #t this
;;   very same value is returned.

;;; Code:

(define-module (ice-9 ftw)
  :export (ftw nftw))

(define (directory-files dir)
  (let ((dir-stream (opendir dir)))
    (let loop ((new (readdir dir-stream))
               (acc '()))
      (if (eof-object? new)
	  (begin
	    (closedir dir-stream)
	    acc)
          (loop (readdir dir-stream)
                (if (or (string=? "."  new)             ;;; ignore
                        (string=? ".." new))            ;;; ignore
                    acc
                    (cons new acc)))))))

(define (pathify . nodes)
  (let loop ((nodes nodes)
             (result ""))
    (if (null? nodes)
        (or (and (string=? "" result) "")
            (substring result 1 (string-length result)))
        (loop (cdr nodes) (string-append result "/" (car nodes))))))

(define (abs? filename)
  (char=? #\/ (string-ref filename 0)))

;; `visited?-proc' returns a test procedure VISITED? which when called as
;; (VISITED? stat-obj) returns #f the first time a distinct file is seen,
;; then #t on any subsequent sighting of it.
;;
;; stat:dev and stat:ino together uniquely identify a file (see "Attribute
;; Meanings" in the glibc manual).  Often there'll be just one dev, and
;; usually there's just a handful mounted, so the strategy here is a small
;; hash table indexed by dev, containing hash tables indexed by ino.
;;
;; It'd be possible to make a pair (dev . ino) and use that as the key to a
;; single hash table.  It'd use an extra pair for every file visited, but
;; might be a little faster if it meant less scheme code.
;;
(define (visited?-proc size)
  (let ((dev-hash (make-hash-table 7)))
    (lambda (s)
      (and s
	   (let ((ino-hash (hashv-ref dev-hash (stat:dev s)))
		 (ino      (stat:ino s)))
	     (or ino-hash
		 (begin
		   (set! ino-hash (make-hash-table size))
		   (hashv-set! dev-hash (stat:dev s) ino-hash)))
	     (or (hashv-ref ino-hash ino)
		 (begin
		   (hashv-set! ino-hash ino #t)
		   #f)))))))

(define (stat-dir-readable?-proc uid gid)
  (let ((uid (getuid))
        (gid (getgid)))
    (lambda (s)
      (let* ((perms (stat:perms s))
             (perms-bit-set? (lambda (mask)
                               (not (= 0 (logand mask perms))))))
        (or (and (= uid (stat:uid s))
                 (perms-bit-set? #o400))
            (and (= gid (stat:gid s))
                 (perms-bit-set? #o040))
            (perms-bit-set? #o004))))))

(define (stat&flag-proc dir-readable? . control-flags)
  (let* ((directory-flag (if (memq 'depth control-flags)
                             'directory-processed
                             'directory))
         (stale-symlink-flag (if (memq 'nftw-style control-flags)
                                 'stale-symlink
                                 'symlink))
         (physical? (memq 'physical control-flags))
         (easy-flag (lambda (s)
                      (let ((type (stat:type s)))
                        (if (eq? 'directory type)
                            (if (dir-readable? s)
                                directory-flag
                                'directory-not-readable)
                            'regular)))))
    (lambda (name)
      (let ((s (false-if-exception (lstat name))))
        (cond ((not s)
               (values s 'invalid-stat))
              ((eq? 'symlink (stat:type s))
               (let ((s-follow (false-if-exception (stat name))))
                 (cond ((not s-follow)
                        (values s stale-symlink-flag))
                       ((and s-follow physical?)
                        (values s 'symlink))
                       ((and s-follow (not physical?))
                        (values s-follow (easy-flag s-follow))))))
              (else (values s (easy-flag s))))))))

(define (clean name)
  (let ((last-char-index (1- (string-length name))))
    (if (char=? #\/ (string-ref name last-char-index))
        (substring name 0 last-char-index)
        name)))

(define (ftw filename proc . options)
  (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
                                        (else 211))))
         (stat&flag (stat&flag-proc
                     (stat-dir-readable?-proc (getuid) (getgid)))))
    (letrec ((go (lambda (fullname)
                   (call-with-values (lambda () (stat&flag fullname))
                     (lambda (s flag)
                       (or (visited? s)
                           (let ((ret (proc fullname s flag))) ; callback
                             (or (eq? #t ret)
                                 (throw 'ftw-early-exit ret))
                             (and (eq? 'directory flag)
                                  (for-each
                                   (lambda (child)
                                     (go (pathify fullname child)))
                                   (directory-files fullname)))
                             #t)))))))
      (catch 'ftw-early-exit
             (lambda () (go (clean filename)))
             (lambda (key val) val)))))

(define (nftw filename proc . control-flags)
  (let* ((od (getcwd))                  ; orig dir
         (odev (let ((s (false-if-exception (lstat filename))))
                 (if s (stat:dev s) -1)))
         (same-dev? (if (memq 'mount control-flags)
                        (lambda (s) (= (stat:dev s) odev))
                        (lambda (s) #t)))
         (base-sub (lambda (name base) (substring name 0 base)))
         (maybe-cd (if (memq 'chdir control-flags)
                       (if (abs? filename)
                           (lambda (fullname base)
                             (or (= 0 base)
                                 (chdir (base-sub fullname base))))
                           (lambda (fullname base)
                             (chdir
                              (pathify od (base-sub fullname base)))))
                       (lambda (fullname base) #t)))
         (maybe-cd-back (if (memq 'chdir control-flags)
                            (lambda () (chdir od))
                            (lambda () #t)))
         (depth-first? (memq 'depth control-flags))
         (visited? (visited?-proc
                    (cond ((memq 'hash-size control-flags) => cadr)
                          (else 211))))
         (has-kids? (if depth-first?
                        (lambda (flag) (eq? flag 'directory-processed))
                        (lambda (flag) (eq? flag 'directory))))
         (stat&flag (apply stat&flag-proc
                           (stat-dir-readable?-proc (getuid) (getgid))
                           (cons 'nftw-style control-flags))))
    (letrec ((go (lambda (fullname base level)
                   (call-with-values (lambda () (stat&flag fullname))
                     (lambda (s flag)
                       (letrec ((self (lambda ()
                                        (maybe-cd fullname base)
                                        ;; the callback
                                        (let ((ret (proc fullname s flag
                                                         base level)))
                                          (maybe-cd-back)
                                          (or (eq? #t ret)
                                              (throw 'nftw-early-exit ret)))))
                                (kids (lambda ()
                                        (and (has-kids? flag)
                                             (for-each
                                              (lambda (child)
                                                (go (pathify fullname child)
                                                    (1+ (string-length
                                                         fullname))
                                                    (1+ level)))
                                              (directory-files fullname))))))
                         (or (visited? s)
                             (not (same-dev? s))
                             (if depth-first?
                                 (begin (kids) (self))
                                 (begin (self) (kids)))))))
                   #t)))
      (let ((ret (catch 'nftw-early-exit
                        (lambda () (go (clean filename) 0 0))
                        (lambda (key val) val))))
        (chdir od)
        ret))))

;;; ftw.scm ends here


code:
;;; gap-buffer.scm --- String buffer that supports point

;;;	Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; A gap buffer is a structure that models a string but allows relatively
;; efficient insertion of text somewhere in the middle.  The insertion
;; location is called `point' with minimum value 1, and a maximum value of the
;; length of the string (which is not fixed).
;;
;; Specifically, we allocate a continuous buffer of characters that is
;; composed of the BEFORE, the GAP and the AFTER (reading L->R), like so:
;;
;;                          +--- POINT
;;                          v
;;    +--------------------+--------------------+--------------------+
;;    |       BEFORE       |        GAP         |       AFTER        |
;;    +--------------------+--------------------+--------------------+
;;
;;     <----- bef-sz ----->|<----- gap-sz ----->|<----- aft-sz ----->
;;
;;     <-------------------|       usr-sz       |------------------->
;;
;;     <-------------------------- all-sz -------------------------->
;;
;; This diagram also shows how the different sizes are computed, and the
;; location of POINT.  Note that the user-visible buffer size `usr-sz' does
;; NOT include the GAP, while the allocation `all-sz' DOES.
;;
;; The consequence of this arrangement is that "moving point" is simply a
;; matter of kicking characters across the GAP, while insertion can be viewed
;; as filling up the gap, increasing `bef-sz' and decreasing `gap-sz'.  When
;; `gap-sz' falls below some threshold, we reallocate with a larger `all-sz'.
;;
;; In the implementation, we actually keep track of the AFTER start offset
;; `aft-ofs' since it is used more often than `gap-sz'.  In fact, most of the
;; variables in the diagram are for conceptualization only.
;;
;; A gap buffer port is a soft port (see Guile manual) that wraps a gap
;; buffer.  Character and string writes, as well as character reads, are
;; supported.  Flushing and closing are not supported.
;;
;; These procedures are exported:
;;   (gb? OBJ)
;;   (make-gap-buffer . INIT)
;;   (gb-point GB)
;;   (gb-point-min GB)
;;   (gb-point-max GB)
;;   (gb-insert-string! GB STRING)
;;   (gb-insert-char! GB CHAR)
;;   (gb-delete-char! GB COUNT)
;;   (gb-goto-char GB LOCATION)
;;   (gb->string GB)
;;   (gb-filter! GB STRING-PROC)
;;   (gb->lines GB)
;;   (gb-filter-lines! GB LINES-PROC)
;;   (make-gap-buffer-port GB)
;;
;; INIT is an optional port or a string.  COUNT and LOCATION are integers.
;; STRING-PROC is a procedure that takes and returns a string.  LINES-PROC is
;; a procedure that takes and returns a list of strings, each representing a
;; line of text (newlines are stripped and added back automatically).
;;
;; (The term and concept of "gap buffer" are borrowed from Emacs.  We will
;; gladly return them when libemacs.so is available. ;-)
;;
;; Notes:
;; - overrun errors are suppressed silently

;;; Code:

(define-module (ice-9 gap-buffer)
  :autoload (srfi srfi-13) (string-join)
  :export (gb?
           make-gap-buffer
           gb-point
           gb-point-min
           gb-point-max
           gb-insert-string!
           gb-insert-char!
           gb-delete-char!
           gb-erase!
           gb-goto-char
           gb->string
           gb-filter!
           gb->lines
           gb-filter-lines!
           make-gap-buffer-port))

(define gap-buffer
  (make-record-type 'gap-buffer
                    '(s                 ; the buffer, a string
                      all-sz            ; total allocation
                      gap-ofs           ; GAP starts, aka (1- point)
                      aft-ofs           ; AFTER starts
                      )))

(define gb? (record-predicate gap-buffer))

(define s:       (record-accessor gap-buffer 's))
(define all-sz:  (record-accessor gap-buffer 'all-sz))
(define gap-ofs: (record-accessor gap-buffer 'gap-ofs))
(define aft-ofs: (record-accessor gap-buffer 'aft-ofs))

(define s!       (record-modifier gap-buffer 's))
(define all-sz!  (record-modifier gap-buffer 'all-sz))
(define gap-ofs! (record-modifier gap-buffer 'gap-ofs))
(define aft-ofs! (record-modifier gap-buffer 'aft-ofs))

;; todo: expose
(define default-initial-allocation 128)
(define default-chunk-size 128)
(define default-realloc-threshold 32)

(define (round-up n)
  (* default-chunk-size (+ 1 (quotient n default-chunk-size))))

(define new (record-constructor gap-buffer '()))

(define (realloc gb inc)
  (let* ((old-s   (s: gb))
         (all-sz  (all-sz: gb))
         (new-sz  (+ all-sz inc))
         (gap-ofs (gap-ofs: gb))
         (aft-ofs (aft-ofs: gb))
         (new-s   (make-string new-sz))
         (new-aft-ofs (+ aft-ofs inc)))
    (substring-move! old-s 0 gap-ofs new-s 0)
    (substring-move! old-s aft-ofs all-sz new-s new-aft-ofs)
    (s! gb new-s)
    (all-sz! gb new-sz)
    (aft-ofs! gb new-aft-ofs)))

(define (make-gap-buffer . init)        ; port/string
  (let ((gb (new)))
    (cond ((null? init)
           (s! gb (make-string default-initial-allocation))
           (all-sz! gb default-initial-allocation)
           (gap-ofs! gb 0)
           (aft-ofs! gb default-initial-allocation))
          (else (let ((jam! (lambda (string len)
                              (let ((alloc (round-up len)))
                                (s! gb (make-string alloc))
                                (all-sz! gb alloc)
                                (substring-move! string 0 len (s: gb) 0)
                                (gap-ofs! gb len)
                                (aft-ofs! gb alloc))))
                      (v (car init)))
                  (cond ((port? v)
                         (let ((next (lambda () (read-char v))))
                           (let loop ((c (next)) (acc '()) (len 0))
                             (if (eof-object? c)
                                 (jam! (list->string (reverse acc)) len)
                                 (loop (next) (cons c acc) (1+ len))))))
                        ((string? v)
                         (jam! v (string-length v)))
                        (else (error "bad init type"))))))
    gb))

(define (gb-point gb)
  (1+ (gap-ofs: gb)))

(define (gb-point-min gb) 1)            ; no narrowing (for now)

(define (gb-point-max gb)
  (1+ (- (all-sz: gb) (- (aft-ofs: gb) (gap-ofs: gb)))))

(define (insert-prep gb len)
  (let* ((gap-ofs (gap-ofs: gb))
         (aft-ofs (aft-ofs: gb))
         (slack (- (- aft-ofs gap-ofs) len)))
    (and (< slack default-realloc-threshold)
         (realloc gb (round-up (- slack))))
    gap-ofs))

(define (gb-insert-string! gb string)
  (let* ((len (string-length string))
         (gap-ofs (insert-prep gb len)))
    (substring-move! string 0 len (s: gb) gap-ofs)
    (gap-ofs! gb (+ gap-ofs len))))

(define (gb-insert-char! gb char)
  (let ((gap-ofs (insert-prep gb 1)))
    (string-set! (s: gb) gap-ofs char)
    (gap-ofs! gb (+ gap-ofs 1))))

(define (gb-delete-char! gb count)
  (cond ((< count 0)                    ; backwards
         (gap-ofs! gb (max 0 (+ (gap-ofs: gb) count))))
        ((> count 0)                    ; forwards
         (aft-ofs! gb (min (all-sz: gb) (+ (aft-ofs: gb) count))))
        ((= count 0)                    ; do nothing
         #t)))

(define (gb-erase! gb)
  (gap-ofs! gb 0)
  (aft-ofs! gb (all-sz: gb)))

(define (point++n! gb n s gap-ofs aft-ofs) ; n>0; warning: reckless
  (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs)
  (gap-ofs! gb (+ gap-ofs n))
  (aft-ofs! gb (+ aft-ofs n)))

(define (point+-n! gb n s gap-ofs aft-ofs) ; n<0; warning: reckless
  (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n))
  (gap-ofs! gb (+ gap-ofs n))
  (aft-ofs! gb (+ aft-ofs n)))

(define (gb-goto-char gb new-point)
  (let ((pmax (gb-point-max gb)))
    (or (and (< new-point 1)    (gb-goto-char gb 1))
        (and (> new-point pmax) (gb-goto-char gb pmax))
        (let ((delta (- new-point (gb-point gb))))
          (or (= delta 0)
              ((if (< delta 0)
                   point+-n!
                   point++n!)
               gb delta (s: gb) (gap-ofs: gb) (aft-ofs: gb))))))
  new-point)

(define (gb->string gb)
  (let ((s (s: gb)))
    (string-append (substring s 0 (gap-ofs: gb))
                   (substring s (aft-ofs: gb)))))

(define (gb-filter! gb string-proc)
  (let ((new (string-proc (gb->string gb))))
    (gb-erase! gb)
    (gb-insert-string! gb new)))

(define (gb->lines gb)
  (let ((str (gb->string gb)))
    (let loop ((start 0) (acc '()))
      (cond ((string-index str #\newline start)
             => (lambda (w)
                  (loop (1+ w) (cons (substring str start w) acc))))
            (else (reverse (cons (substring str start) acc)))))))

(define (gb-filter-lines! gb lines-proc)
  (let ((new-lines (lines-proc (gb->lines gb))))
    (gb-erase! gb)
    (gb-insert-string! gb (string-join new-lines #\newline))))

(define (make-gap-buffer-port gb)
  (or (gb? gb)
      (error "not a gap-buffer:" gb))
  (make-soft-port
   (vector
    (lambda (c) (gb-insert-char! gb c))
    (lambda (s) (gb-insert-string! gb s))
    #f
    (lambda () (let ((gap-ofs (gap-ofs: gb))
                     (aft-ofs (aft-ofs: gb)))
                 (if (= aft-ofs (all-sz: gb))
                     #f
                     (let* ((s (s: gb))
                            (c (string-ref s aft-ofs)))
                       (string-set! s gap-ofs c)
                       (gap-ofs! gb (1+ gap-ofs))
                       (aft-ofs! gb (1+ aft-ofs))
                       c))))
    #f)
   "rw"))

;;; gap-buffer.scm ends here