From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 support/format.scm | 683 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 683 insertions(+)
 create mode 100644 support/format.scm

(limited to 'support/format.scm')

diff --git a/support/format.scm b/support/format.scm
new file mode 100644
index 0000000..c9dbb38
--- /dev/null
+++ b/support/format.scm
@@ -0,0 +1,683 @@
+;;; format.scm -- format function for Scheme
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  29 Oct 1991
+;;;
+;;;
+;;; This code is adapted from the XP pretty printer originally written
+;;; in Common Lisp by Dick Waters.  Here is the copyright notice attached
+;;; to the original XP source file:
+;;;
+;;;------------------------------------------------------------------------
+;;;
+;;; Copyright 1989,1990 by the Massachusetts Institute of Technology,
+;;; Cambridge, Massachusetts.
+;;; 
+;;; Permission to use, copy, modify, and distribute this software and its
+;;; documentation for any purpose and without fee is hereby granted,
+;;; provided that this copyright and permission notice appear in all
+;;; copies and supporting documentation, and that the name of M.I.T. not
+;;; be used in advertising or publicity pertaining to distribution of the
+;;; software without specific, written prior permission. M.I.T. makes no
+;;; representations about the suitability of this software for any
+;;; purpose.  It is provided "as is" without express or implied warranty.
+;;; 
+;;;  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;;;  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;;;  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;;;  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;;;  SOFTWARE.
+;;;
+;;;------------------------------------------------------------------------
+;;;
+
+
+;;; The stream argument can be #f, in which case a string is returned.
+;;; If the stream is #t, (current-output-port) is used.
+;;; We compile a string argument into a function and call the function.
+;;; The only exception is if the string doesn't contain any ~ escapes;
+;;; then we can treat it as a literal and just write it to the stream.
+
+(define (format stream string-or-fn . args)
+  (cond ((not stream)
+	 (call-with-output-string
+	     (lambda (stream)
+	       (apply (function format) stream string-or-fn args))))
+	(else
+	 (if (eq? stream '#t)
+	     (setf stream (current-output-port)))
+	 (when (string? string-or-fn)
+	   (setf string-or-fn (xp.process-format-string string-or-fn)))
+	 (if (string? string-or-fn)
+	     (write-string string-or-fn stream)
+	     (xp.maybe-initiate-xp-printing string-or-fn stream args))
+	 '#f)))
+
+(define xp.format-string-cache (make-table))
+
+(define (xp.process-format-string string-or-fn)
+  (cond ((not (string? string-or-fn)) string-or-fn)
+	((not xp.format-string-cache)
+	 (xp.maybe-compile-format-string string-or-fn))
+	(else
+	 (when (not (table? xp.format-string-cache))
+	   (setf xp.format-string-cache (make-table)))
+	 (let ((value
+		   (table-entry xp.format-string-cache string-or-fn)))
+	   (when (not value)
+	     (setf value (xp.maybe-compile-format-string string-or-fn))
+	     (setf (table-entry xp.format-string-cache string-or-fn)
+		   value))
+	   value))))
+
+
+(define (xp.maybe-compile-format-string string)
+  (let ((length  (string-length string)))
+    (or (xp.simple-format-string? string 0 length)
+	(let ((fn  (xp.parse-format-string string 0 length)))
+	  (lambda (xp args)
+	    (funcall fn xp args args))))))
+
+
+;;; Try to detect format strings without fancy directives, that can be 
+;;; written with a call to  write-string.
+;;; Can do simple transformations e.g. ~% => newline, ~~ => ~, etc.
+
+(define (xp.simple-format-string? s start end)
+  (let ((twiddle  (string-position #\~ s start end)))
+    (if (not twiddle)
+	(if (eqv? start 0)
+	    s
+	    (substring s start end))
+	(let ((char    (string-ref s (1+ twiddle))))
+	  (cond ((eqv? char #\%)
+		 (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
+		   (if tail
+		       (string-append (substring s start twiddle)
+				      (string #\newline)
+				      tail)
+		       '#f)))
+		((eqv? char #\~)
+		 (let ((tail (xp.simple-format-string? s (+ twiddle 2) end)))
+		   (if tail
+		       (string-append (substring s start (1+ twiddle))
+				      tail)
+		       '#f)))
+		((eqv? char #\newline)
+		 (let ((tail (xp.simple-format-string?
+			         s
+				 (xp.skip-whitespace s (+ twiddle 2) end)
+				 end)))
+		   (if tail
+		       (string-append (substring s start twiddle)
+				      tail)
+		       '#f)))
+		(else
+		 '#f))))))
+
+(define (warning string-or-fn . args)
+  (internal-warning (apply (function format) '#f string-or-fn args)))
+
+(define (error string-or-fn . args)
+  (internal-error (apply (function format) '#f string-or-fn args)))
+
+
+;;;=====================================================================
+;;; Compiled format
+;;;=====================================================================
+
+;;; Note that compiled format strings always print through xp streams even if
+;;; they don't have any xp directives in them.  As a result, the compiled code
+;;; can depend on the fact that the stream being operated on is an xp
+;;; stream not an ordinary one.
+
+
+;;; Parse a format string, returning a function to do the printing.
+;;; The function is called with three arguments
+;;;    * the xp stream
+;;;    * the original argument list
+;;;    * the argument list tail
+;;; It should return the list of leftover, unprocessed arguments.
+
+(define (xp.parse-format-string string start end)
+  (cond ((eqv? start end)
+	 (function xp.format-finish))
+	((eqv? (string-ref string start) #\~)
+	 (xp.parse-format-string-dispatch string start end))
+	(else
+	 (let* ((next       (or (string-position #\~ string start end) end))
+		(literal    (substring string start next))
+		(count      (- next start))
+		(continue   (xp.parse-format-string string next end))
+		(newline?   (string-position #\newline literal 0 count)))
+	   (if newline?
+	       (lambda (xp args tail)
+		 (xp.write-string+ literal xp 0 count)
+		 (funcall continue xp args tail))
+	       (lambda (xp args tail)
+		 (xp.write-string++ literal xp 0 count)
+		 (funcall continue xp args tail)))))
+	))
+
+(define (xp.format-finish xp args tail)
+  (declare (ignore xp args))
+  tail)
+
+
+;;; Functions for handling individual format specifiers are installed
+;;; in this table.  They are called with these arguments:
+;;; * the format string
+;;; * the index of the next character
+;;; * the index of the end of the format string
+;;; * the list of parameters for the format specification
+;;; * a boolean indicating whether the colon modifier was present
+;;; * a boolean indicating whether the atsign modifier was present
+;;; The handler is responsible for calling xp.parse-format-string to parse 
+;;; the rest of the format string, and returning a function.  (This has
+;;; to be done by the individual handlers because some of them need to
+;;; scan the format string for matching delimiters, etc.)
+
+;;; *** This probably isn't right, we assume characters can be compared
+;;; *** with EQ? and used as table keys.
+
+(define xp.fn-table (make-table))
+
+(define (define-format char function)
+  (setf (table-entry xp.fn-table (char-upcase char)) function)
+  (setf (table-entry xp.fn-table (char-downcase char)) function))
+
+;;; Parse a ~ sequence from the format string and dispatch to the
+;;; appropriate handler.  
+
+(define (xp.parse-format-string-dispatch string start end)
+  (multiple-value-bind (next params colon? atsign? char)
+      (xp.parse-format-descriptor string start end)
+    (let ((fn  (table-entry xp.fn-table char)))
+      (if fn
+	  (funcall fn string next end params colon? atsign?)
+	  (error "Unrecognized format escape ~~~a." char)))))
+
+(define (xp.parse-format-descriptor string start end)
+  (multiple-value-bind (params start)
+      (xp.parse-format-parameters string start end)
+    (let ((colon?    '#f)
+	  (atsign?   '#f)
+	  (char      '#f))
+      (block parse-format-descriptor
+	(do ()
+	    ((xp.check-for-incomplete-format-string string start end))
+	    (setf char (string-ref string start))
+	    (incf start)
+	    (cond ((eqv? char #\:)
+		   (setf colon? '#t))
+		  ((eqv? char #\@)
+		   (setf atsign? '#t))
+		  (else
+		   (return-from parse-format-descriptor
+		     (values start params colon? atsign? char)))
+		))))))
+
+
+;;; *** The stuff for V and # format parameters is disabled because
+;;; *** it makes the handler functions hairier.  It's rarely used anyway,
+;;; *** and you can get the same effect by consing up a format string
+;;; *** on the fly if you really need to.
+
+(define (xp.parse-format-parameters string start end)
+  (let ((params  '())
+	(char    '#f))
+    (incf start)  ; skip ~
+    (block parse-format-parameters
+      (do ()
+	  ((xp.check-for-incomplete-format-string string start end))
+	  (setf char (string-ref string start))
+	  (cond ((char-numeric? char)
+		 (multiple-value-bind (next value)
+		     (xp.parse-format-number string start end 0)
+		   (setf start next)
+		   (push value params)))
+		((eqv? char #\')
+		 (push (string-ref string (1+ start)) params)
+		 (setf start (+ start 2)))
+		((or (eqv? char #\v) (eqv? char #\V))
+		 (error "V format parameter not supported.")  ;***
+		 (push 'value params)
+		 (setf start (+ start 1)))
+		((eqv? char #\#)
+		 (error "# format parameter not supported.")  ;***
+		 (push 'count params)
+		 (setf start (+ start 1)))
+		((eqv? char #\,)
+		 (push '#f params))
+		(else
+		 (return-from parse-format-parameters
+		   (values (nreverse params) start))))
+	  (if (eqv? (string-ref string start) #\,)
+	      (incf start))))))
+
+(define (xp.parse-format-number string start end value)
+  (xp.check-for-incomplete-format-string string start end)
+  (let* ((char    (string-ref string start))
+	 (weight  (string-position char "0123456789" 0 10)))
+    (if weight
+	(xp.parse-format-number string (1+ start) end (+ (* value 10) weight))
+	(values start value))))
+
+(define (xp.check-for-incomplete-format-string string start end)
+  (if (eqv? start end)
+      (error "Incomplete format string ~s." string)
+      '#f))
+
+
+;;; *** All of these format handlers probably ought to do more checking
+;;; *** for the right number of parameters and not having colon? and
+;;; *** atsign? supplied when they are not allowed.
+
+;;; ~A and ~S are the basic format directives.
+
+(define (xp.format-a string start end params colon? atsign?)
+  (xp.format-a-s-helper string start end params colon? atsign? '#f))
+(define-format #\a (function xp.format-a))
+
+(define (xp.format-s string start end params colon? atsign?)
+  (xp.format-a-s-helper string start end params colon? atsign? '#t))
+(define-format #\s (function xp.format-s))
+
+(define (xp.format-a-s-helper string start end params colon? atsign? escape?)
+  (declare (ignore colon? atsign?))  ;***
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (if (null? params)
+	;; Do the simple, common case.
+	(lambda (xp args tail)
+	  (dynamic-let ((*print-escape*   escape?))
+	    (xp.write+ (car tail) xp))
+	  (funcall continuation xp args (cdr tail)))
+	;; Do the hard case.
+	(let* ((mincol   (or (and (not (null? params)) (pop params)) 0))
+	       (colinc   (or (and (not (null? params)) (pop params)) 1))
+	       (minpad   (or (and (not (null? params)) (pop params)) 0))
+	       (padchar  (or (and (not (null? params)) (pop params)) #\space)))
+	  (declare (ignore mincol colinc minpad padchar))  ;***
+;;; *** I'm confused.  It seems like we have to print this to a string
+;;; *** and then write the string to the XP stream along with the padding
+;;; *** But won't switching to a new stream mess up circularity detection, 
+;;; *** indentation, etc?
+	  (error "Unimplemented format option ~s!" string))
+      )))
+
+
+;;; ~W -> write
+
+(define (xp.format-w string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (xp.write+ (car tail) xp)
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? (not atsign?))
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-pretty*  '#t))
+	       (xp.write+ (car tail) xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-level*  '#f)
+			   (*print-length* '#f))
+	       (xp.write+ (car tail) xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? atsign?)
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-level*  '#f)
+			   (*print-length* '#f)
+			   (*print-pretty* '#t))
+	       (xp.write+ (car tail) xp))
+	     (funcall continuation xp args (cdr tail))))
+	  )))
+(define-format #\w (function xp.format-w))
+
+
+;;; Here are the directives for printing integers, ~D and friends.
+
+(define (xp.format-d string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 10))
+(define-format #\d (function xp.format-d))
+
+(define (xp.format-b string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 2))
+(define-format #\b (function xp.format-b))
+
+(define (xp.format-o string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 8))
+(define-format #\o (function xp.format-o))
+
+(define (xp.format-x string start end params colon? atsign?)
+  (xp.format-d-b-o-x-helper string start end params colon? atsign? 16))
+(define-format #\x (function xp.format-x))
+
+(define (xp.format-d-b-o-x-helper string start end params colon? atsign? radix)
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (if (and (null? params) (not colon?) (not atsign?))
+	;; Do the simple, common case.
+	(lambda (xp args tail)
+	  (dynamic-let ((*print-escape*  '#f)
+			(*print-radix*   '#f)
+			(*print-base*    radix))
+	    (xp.write+ (car tail) xp))
+	  (funcall continuation xp args (cdr tail)))
+	;; Do the hard case.
+	(let* ((mincol    (or (and (not (null? params)) (pop params)) 0))
+	       (padchar   (or (and (not (null? params)) (pop params)) #\space))
+	       (commachar (or (and (not (null? params)) (pop params)) #\,))
+	       (commaint  (or (and (not (null? params)) (pop params)) 3)))
+	  (declare (ignore mincol padchar commachar commaint))  ;***
+	  ;; *** I'm too lazy to do this right now.
+	  (error "Unimplemented format option ~s!" string)))))
+
+
+(define (xp.format-r string start end params colon? atsign?)
+  (if (not (null? params))
+      (xp.format-d-b-o-x-helper string start end (cdr params)
+			     colon? atsign? (car params))
+      ;; *** The colon? and atsign? modifiers do weird things like
+      ;; *** printing roman numerals.  I'm too lazy to do this until/unless
+      ;; *** we have a real need for it.
+      (error "Unimplemented format option ~s!" string)))
+(define-format #\r (function xp.format-r))
+
+
+;;; ~P -> plurals
+
+(define (xp.format-p string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (if (not (eqv? (car tail) 1))
+		 (xp.write-char++ #\s xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? (not atsign?))
+	   (lambda (xp args tail)
+	     (setf tail (xp.back-up 1 args tail))
+	     (if (not (eqv? (car tail) 1))
+		 (xp.write-char++ #\s xp))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (if (eqv? (car tail) 1)
+		 (xp.write-char++ #\y xp)
+		 (begin
+		   (xp.write-char++ #\i xp)
+		   (xp.write-char++ #\e xp)
+		   (xp.write-char++ #\s xp)))
+	     (funcall continuation xp args (cdr tail))))
+	  ((and colon? atsign?)
+	   (lambda (xp args tail)
+	     (setf tail (xp.back-up 1 args tail))
+	     (if (eqv? (car tail) 1)
+		 (xp.write-char++ #\y xp)
+		 (begin
+		   (xp.write-char++ #\i xp)
+		   (xp.write-char++ #\e xp)
+		   (xp.write-char++ #\s xp)))
+	     (funcall continuation xp args (cdr tail)))))))
+(define-format #\p (function xp.format-p))
+
+
+;;; ~C -> character
+
+(define (xp.format-c string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (xp.write-char++ (car tail) xp)
+	     (funcall continuation xp args (cdr tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (dynamic-let ((*print-escape*  '#t))
+	       (xp.write+ (car tail) xp)
+	       (funcall continuation xp args (cdr tail)))))
+	  (else
+	   ;; *** I don't know how to get at the character names.
+	   (error "Unimplemented format option ~s!" string)))))
+(define-format #\c (function xp.format-c))
+
+
+
+;;; Newline directives, ~% and ~&
+
+(define (xp.format-percent string start end params colon? atsign?)
+  (xp.format-newline-helper string start end params colon? atsign?
+			 'unconditional))
+(define-format #\% (function xp.format-percent))
+
+(define (xp.format-ampersand string start end params colon? atsign?)
+  (xp.format-newline-helper string start end params colon? atsign?
+			 'fresh))
+(define-format #\& (function xp.format-ampersand))
+
+(define (xp.format-newline-helper string start end params colon? atsign? kind)
+  (declare (ignore colon? atsign?))
+  (let ((continuation (xp.parse-format-string string start end))
+	(n            (or (and (not (null? params)) (pop params)) 1)))
+    (if (eqv? n 1)
+	(lambda (xp args tail)
+	  (xp.pprint-newline+ kind xp)
+	  (funcall continuation xp args tail))
+	(lambda (xp args tail)
+	  (xp.pprint-newline+ kind xp)
+	  (dotimes (i (1- n))
+	    (xp.pprint-newline+ 'unconditional xp))
+	  (funcall continuation xp args tail))
+      )))
+
+
+;;; ~_, Conditional newline
+
+(define (xp.format-underbar string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((continuation  (xp.parse-format-string string start end))
+	(kind          (if colon?
+			   (if atsign? 'mandatory 'fill)
+			   (if atsign? 'miser 'linear))))
+    (lambda (xp args tail)
+      (xp.pprint-newline+ kind xp)
+      (funcall continuation xp args tail))))
+(define-format #\_ (function xp.format-underbar))
+
+
+;;; Random character printing directives, ~| and ~~
+
+;;; *** commented out because #\page is not standard scheme
+; (define (xp.format-bar string start end params colon? atsign?)
+;  (xp.format-char-helper string start end params colon? atsign? #\page))
+; (define-format #\| (function xp.format-bar))
+
+(define (xp.format-twiddle string start end params colon? atsign?)
+  (xp.format-char-helper string start end params colon? atsign? #\~))
+(define-format #\~ (function xp.format-twiddle))
+
+(define (xp.format-char-helper string start end params colon? atsign? char)
+  (declare (ignore colon? atsign?))
+  (let ((continuation  (xp.parse-format-string string start end))
+	(n             (or (and (not (null? params)) (pop params)) 1)))
+    (if (eqv? n 1)
+	(lambda (xp args tail)
+	  (xp.write-char++ char xp)
+	  (funcall continuation xp args tail))
+	(lambda (xp args tail)
+	  (dotimes (i n)
+	    (xp.write-char++ char xp))
+	  (funcall continuation xp args tail)))))
+
+
+
+;;; ~<newline> directive (ignore whitespace in format string)
+
+(define (xp.format-newline string start end params colon? atsign?)
+  (declare (ignore params))
+  (let ((newline?   '#f)
+	(skip?      '#f))
+    (cond ((and (not colon?) (not atsign?))  ; skip both newline and whitespace
+	   (setf skip? '#t))
+	  ((and colon? (not atsign?)))  ; skip newline, leave whitespace
+	  ((and (not colon?) atsign?)   ; do newline, skip whitespace
+	   (setf newline? '#t)
+	   (setf skip? '#t))
+	  (else
+	   (error "~:@<newline> not allowed.")))
+    (if skip?
+	(setf start (xp.skip-whitespace string start end)))
+    (let ((continuation  (xp.parse-format-string string start end)))
+      (if newline?
+	  (lambda (xp args tail)
+	    (xp.pprint-newline+ 'unconditional xp)
+	    (funcall continuation xp args tail))
+	  continuation))))
+(define-format #\newline (function xp.format-newline))
+
+(define (xp.skip-whitespace string start end)
+  (if (eqv? start end)
+      start
+      (let ((char  (string-ref string start)))
+	(if (and (char-whitespace? char)
+		 (not (eqv? char #\newline)))
+	    (xp.skip-whitespace string (1+ start) end)
+	    start))))
+
+
+
+;;; ~T -> tab
+
+(define (xp.format-t string start end params colon? atsign?)
+  (let* ((continuation  (xp.parse-format-string string start end))
+	 (colnum        (or (and (not (null? params)) (pop params)) 1))
+	 (colinc        (or (and (not (null? params)) (pop params)) 1))
+	 (kind          (if colon?
+			    (if atsign? 'section-relative 'section)
+			    (if atsign? 'line-relative 'line))))
+    (lambda (xp args tail)
+      (xp.pprint-tab+ kind colnum colinc xp)
+      (funcall continuation xp args tail))))
+(define-format #\t (function xp.format-t))
+
+
+;;; ~I -> indent
+
+(define (xp.format-i string start end params colon? atsign?)
+  (declare (ignore atsign?))
+  (let ((continuation  (xp.parse-format-string string start end))
+	(kind          (if colon? 'current 'block))
+	(n             (or (and (not (null? params)) (pop params)) 0)))
+    (lambda (xp args tail)
+      (pprint-indent kind n)
+      (funcall continuation xp args tail))))
+(define-format #\i (function xp.format-i))
+
+
+;;; ~* -> skip or back up over arguments
+
+(define (xp.format-star string start end params colon? atsign?)
+  (let ((continuation  (xp.parse-format-string string start end))
+	(n             (or (and (not (null? params)) (pop params)) 1)))
+    (cond ((and (not colon?) (not atsign?))
+	   (lambda (xp args tail)
+	     (funcall continuation xp args (list-tail tail n))))
+	  ((and colon? (not atsign?))
+	   (lambda (xp args tail)
+	     (funcall continuation xp args (xp.back-up n args tail))))
+	  ((and (not colon?) atsign?)
+	   (lambda (xp args tail)
+	     (declare (ignore tail))
+	     (funcall continuation xp args (list-tail args n))))
+	  (else
+	   (error "~:@* not allowed.")))))
+(define-format #\* (function xp.format-star))
+
+(define (xp.back-up n head tail)
+  (if (eq? (list-tail head n) tail)
+      head
+      (xp.back-up n (cdr head) tail)))
+
+
+;;; ~? -> indirection
+;;; Normally uses two arguments, a string and a list.
+;;; With @, only uses a string, takes arguments from the tail.
+
+(define (xp.format-question string start end params colon? atsign?)
+  (declare (ignore params colon?))
+  (let ((continuation  (xp.parse-format-string string start end)))
+    (if atsign?
+	(lambda (xp args tail)
+	  (setf tail (apply (function format) xp (car tail) (cdr tail)))
+	  (funcall continuation xp args tail))
+	(lambda (xp args tail)
+	  (apply (function format) xp (car tail) (cadr tail))
+	  (funcall continuation xp args (cddr tail))))))
+(define-format #\? (function xp.format-question))
+
+
+;;; ~(...~) -> case conversion.
+
+(define *xp.format-paren-next* '#f)
+
+(define (xp.format-paren string start end params colon? atsign?)
+  (declare (ignore params))
+  (let* ((handler      (dynamic-let ((*xp.format-paren-next* '#t))
+			 (let ((result (xp.parse-format-string
+					   string start end)))
+			   (if (eq? (dynamic *xp.format-paren-next*) '#t)
+			       (error "~( directive has no matching ~)."))
+			   (setf start (dynamic *xp.format-paren-next*))
+			   result)))
+	 (continuation (xp.parse-format-string string start end))
+	 (mode         (if colon?
+			   (if atsign? 'up 'cap1)
+			   (if atsign? 'cap0 'down))))
+    (lambda (xp args tail)
+      (xp.push-char-mode xp mode)
+      (setf tail (funcall handler xp args tail))
+      (xp.pop-char-mode xp)
+      (funcall continuation xp args tail))))
+(define-format #\( (function xp.format-paren))
+
+(define (xp.format-paren-end string start end params colon? atsign?)
+  (declare (ignore string end params colon? atsign?))
+  (if (not (dynamic *xp.format-paren-next*))
+      (error "~) directive has no matching ~(."))
+  (setf (dynamic *xp.format-paren-next*) start)
+  (function xp.format-finish))
+(define-format #\) (function xp.format-paren-end))
+
+;;; ~F      -> fixed-width      *** unimplemented
+;;; ~E      -> e-notation       *** unimplemented
+;;; ~G      -> general float    *** unimplemented
+;;; ~$      -> dollars float    *** unimplemented
+;;; ~[...~] -> conditional      *** unimplemented
+;;; ~{...~} -> iteration        *** unimplemented
+;;; ~<...~> -> justification    *** unimplemented
+;;; ~;      -> clause seperator *** unimplemented
+;;; ~^      -> up and out       *** unimplemented
+;;; ~/.../  -> hook             *** unimplemented
+
+(define (xp.unimplemented-format string start end params colon? atsign?)
+  (declare (ignore start end params colon? atsign?))
+  (error "Unimplemented format directive in ~s." string))
+
+(define-format #\f (function xp.unimplemented-format))
+(define-format #\e (function xp.unimplemented-format))
+(define-format #\g (function xp.unimplemented-format))
+(define-format #\$ (function xp.unimplemented-format))
+(define-format #\[ (function xp.unimplemented-format))
+(define-format #\] (function xp.unimplemented-format))
+(define-format #\{ (function xp.unimplemented-format))
+(define-format #\} (function xp.unimplemented-format))
+(define-format #\< (function xp.unimplemented-format))
+(define-format #\> (function xp.unimplemented-format))
+(define-format #\; (function xp.unimplemented-format))
+(define-format #\^ (function xp.unimplemented-format))
+(define-format #\/ (function xp.unimplemented-format))
+
-- 
cgit v1.2.3