summaryrefslogtreecommitdiff
path: root/support/format.scm
diff options
context:
space:
mode:
Diffstat (limited to 'support/format.scm')
-rw-r--r--support/format.scm683
1 files changed, 683 insertions, 0 deletions
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))
+
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-16 19:26:15 +0000