diff --git a/code/format.lisp b/code/format.lisp index cd2adf69af646b29165e08246aaef33befad5612..d56402d0df2c839ebd85e3781de006958400b611 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -1,4 +1,4 @@ -;;; -*- Log: code.log; Package: Lisp -*- +;;; -*- Package: FORMAT -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at @@ -7,1238 +7,581 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.9 1991/07/08 13:09:36 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.10 1991/11/29 19:38:19 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; Functions to implement FORMAT for Spice Lisp. +;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp. ;;; -;;; Original by David Adam. -;;; Re-write by Bill Maddox. -;;; Currently not maintained. -;;; -;;; FORMAT is part of the standard Spice Lisp environment. -;;; -(in-package "LISP") - -(export '(format)) - -;;; Special variables local to FORMAT - -(defvar *format-control-string* "" - "The current FORMAT control string") - -(defvar *format-index* 0 - "The current index into *format-control-string*") +;;; Written by William Lott, with lots of stuff stolen from the previous +;;; version by David Adam and later rewritten by Bill Maddox. +;;; -(defvar *format-length* 0 - "The length of the current FORMAT control string") +(in-package "FORMAT") +(use-package "EXT") -(defvar *format-arguments* () - "Arguments to the current call of FORMAT") - -(defvar *format-original-arguments* () - "Saved arglist from top-level FORMAT call for ~* and ~@*") - -(defvar *format-stream-stack* () - "A stack of string streams for collecting FORMAT output") - -(defvar *format-dispatch-table* () - "Dispatch table for FORMAT commands") - - -;;; Specials imported from PRINT and STREAM +(in-package "LISP") +(export '(format formatter)) + +(in-package "FORMAT") + +(deftype boolean () + '(member t nil)) +(deftype index () + '(and unsigned-byte fixnum)) + +(defstruct (format-directive + (:print-function %print-format-directive)) + (string (required-argument) :type simple-string) + (start (required-argument) :type (and unsigned-byte fixnum)) + (end (required-argument) :type (and unsigned-byte fixnum)) + (character (required-argument) :type base-character) + (colonp nil :type (member t nil)) + (atsignp nil :type (member t nil)) + (params nil :type list)) + +(defun %print-format-directive (struct stream depth) + (declare (ignore depth)) + (format stream "#<~A>" + (subseq (format-directive-string struct) + (format-directive-start struct) + (format-directive-end struct)))) + +(defvar *format-directive-expanders* + (make-array char-code-limit :initial-element nil)) + +(defun %print-format-error (condition stream) + (format stream + "~:[~;Error in format: ~]~ + ~?~@[~% ~A~% ~V@T^~]" + (format-error-print-banner condition) + (format-error-complaint condition) + (format-error-arguments condition) + (format-error-control-string condition) + (format-error-offset condition))) + +(defvar *default-format-error-control-string* nil) +(defvar *default-format-error-offset* nil) + +(define-condition format-error (error) + ((complaint (required-argument)) + (arguments nil) + (control-string *default-format-error-control-string*) + (offset *default-format-error-offset*) + (print-banner t)) + (:report %print-format-error)) -(proclaim '(special *print-base* *standard-output* *terminal-io*)) -;;; Specials imported from ERRORFUNS + +;;;; TOKENIZE-CONTROL-STRING + +(defun tokenize-control-string (string) + (declare (simple-string string)) + (let ((index 0) + (end (length string)) + (result nil)) + (loop + (let ((next-directive (or (position #\~ string :start index) end))) + (when (> next-directive index) + (push (subseq string index next-directive) result)) + (when (= next-directive end) + (return)) + (let ((directive (parse-directive string next-directive))) + (push directive result) + (setf index (format-directive-end directive))))) + (nreverse result))) + +(defun parse-directive (string start) + (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) + (end (length string))) + (flet ((get-char () + (if (= posn end) + (error 'format-error + :complaint "String ended before directive was found." + :control-string string + :offset start) + (schar string posn)))) + (loop + (let ((char (get-char))) + (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (multiple-value-bind + (param new-posn) + (parse-integer string :start posn :junk-allowed t) + (push param params) + (setf posn new-posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return))))) + ((or (char= char #\v) (char= char #\V)) + (push :arg params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\#) + (push :remaining params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\') + (incf posn) + (push (get-char) params)) + ((char= char #\,) + (push nil params)) + ((char= char #\:) + (if colonp + (error 'format-error + :complaint "Too many colons supplied." + :control-string string + :offset posn) + (setf colonp t))) + ((char= char #\@) + (if atsignp + (error 'format-error + :complaint "Too many at-signs supplied." + :control-string string + :offset posn) + (setf atsignp t))) + (t + (when (char= (schar string (1- posn)) #\,) + (push nil params)) + (return)))) + (incf posn)) + (let ((char (get-char))) + (when (char= char #\/) + (let ((closing-slash (position #\/ string :start (1+ posn)))) + (if closing-slash + (setf posn closing-slash) + (error 'format-error + :complaint "No matching closing slash." + :control-string string + :offset posn)))) + (make-format-directive + :string string :start start :end (1+ posn) :character char + :colonp colonp :atsignp atsignp + :params (nreverse params)))))) -(proclaim '(special *error-output*)) -;;;; ERRORS - -;;; Since errors may occur while an indirect control string is being -;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary -;;; in order to indicate the location in the control string where the -;;; error was detected. To this end, errors detected by format are -;;; signalled by throwing a list of the form ((control-string args)) -;;; to the tag FORMAT-ERROR. This throw will be caught at each level -;;; of indirection, and the list of error messages re-thrown with an -;;; additional message indicating that indirection was present CONSed -;;; onto it. Ultimately, the last throw will be caught by the top level -;;; FORMAT function, which will then signal an error to the Lisp error -;;; system in such a way that all the errror messages will be displayed -;;; in reverse order. - -(defun format-error (complaint &rest args) - (throw 'format-error - (list (list "~1{~:}~%~S~%~V@T^" complaint args - *format-control-string* (1+ *format-index*))))) - - - -;;; MACROS - -;;; This macro establishes the correct environment for processing -;;; an indirect control string. CONTROL-STRING is the string to -;;; process, and FORMS are the forms to do the processing. They -;;; invariably will involve a call to SUB-FORMAT. CONTROL-STRING -;;; is guaranteed to be evaluated exactly once. - -(defmacro format-with-control-string (control-string &body forms) - `(let ((string (if (simple-string-p ,control-string) - ,control-string - (coerce ,control-string 'simple-string)))) - (declare (simple-string string)) - (let ((error (catch 'format-error - (let ((*format-control-string* string) - (*format-length* (length string)) - (*format-index* 0)) - (declare (simple-string *format-control-string*) - (fixnum *format-length* *format-index*)) - ,@forms - nil)))) - (when error - (throw 'format-error - (cons (list "While processing indirect control string~%~S~%~V@T^" - *format-control-string* - (1+ *format-index*)) - error)))))) +;;;; FORMAT + +(defun my-format (dest string &rest args) + (etypecase dest + (null + (with-output-to-string (stream) + (%format stream string args))) + (string + (with-output-to-string (stream dest) + (%format stream string args))) + ((member t) + (%format *standard-output* string args) + nil) + (stream + (%format dest string args) + nil))) + +(defun %format (stream string-or-fun orig-args &optional (args orig-args)) + (if (functionp string-or-fun) + (apply string-or-fun stream args) + (funcall (make-%format-fun (etypecase string-or-fun + (simple-string + string-or-fun) + (string + (coerce string-or-fun 'simple-string)))) + stream orig-args args))) + +(defun-cached (make-%format-fun + :hash-function (lambda (string) + (let ((sxhash (sxhash string))) + (logxor (ldb (byte 8 0) sxhash) + (ldb (byte 8 6) sxhash) + (ldb (byte 8 12) sxhash)))) + :hash-bits 8) + ((string (lambda (s1 s2) + (and s1 s2 (string= s1 s2))))) + (coerce `(lambda (stream orig-args args) + (declare (ignorable orig-args)) + ,(expand-control-string string) + args) + 'function)) -;;;; WITH-FORMAT-PARAMETERS, and other useful macros. -;;; This macro rebinds collects output to the standard output stream -;;; in a string. For efficiency, we avoid consing a new stream on -;;; every call. A stack of string streams is maintained in order to -;;; guarantee re-entrancy. - -(defmacro format-stringify-output (&body forms) - `(let ((*standard-output* - (if *format-stream-stack* - (pop *format-stream-stack*) - (make-string-output-stream)))) - (unwind-protect - (progn ,@forms - (prog1 - (get-output-stream-string *standard-output*) - (push *standard-output* *format-stream-stack*))) - (get-output-stream-string *standard-output*)))) - - - -;;; Pops an argument from the current argument list. This is either the -;;; list of arguments given to the top-level call to FORMAT, or the argument -;;; list for the current iteration in a ~{~} construct. An error is signalled -;;; if the argument list is empty. - -(defmacro pop-format-arg () - '(if *format-arguments* - (pop *format-arguments*) - (format-error "Missing argument"))) - - -;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. -;;; PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form -;;; (<var> <default>). The FORMS are evaluated in an environment where each -;;; <var> is bound to either the value of the parameter supplied in the -;;; parameter list, or to its <default> value if the parameter was omitted or -;;; explicitly defaulted. - -(defmacro with-format-parameters (parmvar parmdefs &body forms) - (do ((parmdefs parmdefs (cdr parmdefs)) - (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar)) - ,(cadar parmdefs))) - bindings))) - ((null parmdefs) - `(let ,(nreverse bindings) - (when ,parmvar - (format-error "Too many parameters")) - ,@forms)))) +;;;; FORMATTER +(defmacro formatter (control-string) + `#',(%formatter control-string)) - -;;;; Control String Parsing - -;;; The current control string is kept in *format-control-string*. -;;; The variable *format-index* is the position of the last character -;;; processed, indexing from zero. The variable *format-length* is the -;;; length of the control string, which is one greater than the maximum -;;; value of *format-index*. - - -;;; Gets the next character from the current control string. It is an -;;; error if there is none. Leave *format-index* pointing to the -;;; character returned. - -(defmacro nextchar () - '(if (< (the fixnum (incf (the fixnum *format-index*))) - (the fixnum *format-length*)) - (schar *format-control-string* *format-index*) - (format-error "Syntax error"))) - - -;;; Returns the current character, i.e. the one pointed to by *format-index*. - -(defmacro format-peek () - '(schar *format-control-string* *format-index*)) - - -;;; Returns the index of the first occurrence of the specified character -;;; between indices START (inclusive) and END (exclusive) in the control -;;; string. - - -(defmacro format-find-char (char start end) - `(position ,char (the simple-string *format-control-string*) - :start ,start :end ,end :test #'char=)) - - -;;; Attempts to parse a parameter, starting at the current index. -;;; Returns the value of the parameter, or NIL if none is found. -;;; On exit, *format-index* points to the first character which is -;;; not a part of the recognized parameter. - -(defun format-get-parameter () - (case (format-peek) - (#\# (nextchar) (length (the list *format-arguments*))) - ((#\V #\v) (prog1 (pop-format-arg) (nextchar))) - (#\' (prog1 (nextchar) (nextchar))) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (do* ((number (digit-char-p (format-peek)) - (+ (* 10 number) (digit-char-p (format-peek))))) - ((not (digit-char-p (nextchar))) number))) - (#\- - (nextchar) - (case (format-peek) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (do* ((number (digit-char-p (format-peek)) - (+ (* 10 number) (digit-char-p (format-peek))))) - ((not (digit-char-p (nextchar))) (- number)))) - (t (decf (the fixnum *format-index*)) ; put back to out of place "-" - nil))) - (#\+ - (nextchar) - (case (format-peek) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (do* ((number (digit-char-p (format-peek)) - (+ (* 10 number) (digit-char-p (format-peek))))) - ((not (digit-char-p (nextchar))) number))) - (t (decf (the fixnum *format-index*)) ; put back to out of place "-" - nil))) - (t nil))) +(defun %formatter (control-string) + `(lambda (stream &rest orig-args) + (let ((args orig-args)) + ,(expand-control-string control-string) + args))) -;;;; Parsing the directives to FORMAT. - -;;; PARSE-FORMAT-OPERATION parses a format directive, including flags and -;;; parameters. On entry, *format-index* should point to the "~" preceding the -;;; command. On exit, *format-index* points to the command character itself. -;;; Returns the list of parameters, the ":" flag, the "@" flag, and the command -;;; character as multiple values. Explicitly defaulted parameters appear in -;;; the list of parameters as NIL. Omitted parameters are simply not included -;;; in the list at all. -;;; -(defmacro parse-format-operation-modifier () - `(let ((temp (format-peek))) - (cond ((char= temp #\:) - (nextchar) - (setf colon-p t)) - ((char= temp #\@) - (nextchar) - (setf atsign-p t))))) -;;; -(defun parse-format-operation () - (let* ((ch (nextchar)) - (parms (if (or (digit-char-p ch) - (member ch '(#\, #\# #\V #\v #\' #\+ #\-) :test #'char=)) - (do ((parms (list (format-get-parameter)) - (cons (format-get-parameter) parms))) - ((char/= (format-peek) #\,) (nreverse parms)) - (declare (list parms)) - (nextchar)) - '())) - colon-p atsign-p) - (parse-format-operation-modifier) - (parse-format-operation-modifier) - (values parms colon-p atsign-p (format-peek)))) - - - -;;; Starting at the current value of *format-index*, finds the first -;;; occurrence of one of the specified directives. Embedded constructs, -;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored. And error is -;;; signalled if no satisfactory command is found. Otherwise, the -;;; following are returned as multiple values: -;;; -;;; The value of *format-index* at the start of the search -;;; The index of the "~" character preceding the command -;;; The parameter list of the command -;;; The ":" flag -;;; The "@" flag -;;; The command character -;;; -;;; Implementation note: The present implementation is not particulary -;;; careful with storage allocation. It would be a good idea to have -;;; a separate function for skipping embedded constructs which did not -;;; bother to cons parameter lists and then throw them away. -;;; -;;; We go to some trouble here to use POSITION for most of the searching. -;;; -;;; Another note: *FORMAT-ARGUMENTS* is let bound here so that we can -;;; guarantee that that list is not changed by FORMAT-FIND-COMMAND. -;;; This is necessary since PARSE-FORMAT-OPERATION (called below) calls -;;; FORMAT-GET-PARAMETER. If the parameter is #\V or #\v then -;;; FORMAT-GET-PARAMETER will pop *FORMAT-ARGUMENTS*. This causes the -;;; argument to be lost when we actually go to do the real formatting. -;;; -(defun format-find-command (command-list) - (let ((start *format-index*) - (*format-arguments* *format-arguments*)) - (do ((place start *format-index*) - (tilde (format-find-char #\~ start *format-length*) - (format-find-char #\~ place *format-length*))) - ((not tilde) - (format-error "Expecting one of ~S" command-list)) - (setq *format-index* tilde) - (multiple-value-bind (parms colon atsign command) - (parse-format-operation) - (when (member command command-list :test #'char=) - (return (values start tilde parms colon atsign command))) - (case command - (#\{ (nextchar)(format-find-command '(#\}))) - (#\< (nextchar)(format-find-command '(#\>))) - (#\( (nextchar)(format-find-command '(#\)))) - (#\[ (nextchar)(format-find-command '(#\]))) - ((#\} #\> #\) #\]) - (format-error "No matching bracket"))))))) - - - -;;;; This is the FORMAT top-level function. - -(defun format (destination control-string &rest format-arguments) - "Provides various facilities for formatting output. - CONTROL-STRING contains a string to be output, possibly with embedded - directives, which are flagged with the escape character \"~\". Directives - generally expand into additional text to be output, usually consuming one - or more of the FORMAT-ARGUMENTS in the process. A few useful directives - are: - ~A or ~nA Prints one argument as if by PRINC - ~S or ~nS Prints one argument as if by PRIN1 - ~D or ~nD Prints one argument as a decimal integer - ~% Does a TERPRI - ~& Does a FRESH-LINE - - where n is the width of the field in which the object is printed. - - DESTINATION controls where the result will go. If DESTINATION is T, then - the output is sent to the standard output stream. If it is NIL, then the - output is returned in a string as the value of the call. Otherwise, - DESTINATION must be a stream to which the output will be sent. - - Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\" - - FORMAT has many additional capabilities not described here. Consult the - manual for details." - - (let ((*format-original-arguments* format-arguments) ;for abs. and rel. goto - (*format-arguments* format-arguments) - (*print-radix* nil) - (*format-control-string* - (if (simple-string-p control-string) - control-string - (coerce control-string 'simple-string)))) - (declare (simple-string *format-control-string*)) - (cond - ((not destination) - (format-stringify-output - (let ((errorp (catch 'format-error - (catch 'format-escape - (catch 'format-colon-escape - (sub-format 0 (length *format-control-string*)))) - nil))) - (when errorp - (error "~%~:{~@?~%~}" (nreverse errorp)))))) - ((and (stringp destination) (array-has-fill-pointer-p destination)) - (with-output-to-string (*standard-output* destination) - (let ((errorp (catch 'format-error - (catch 'format-escape - (catch 'format-colon-escape - (sub-format 0 (length *format-control-string*)))) - nil))) - (when errorp - (error "~%~:{~@?~%~}" (nreverse errorp))) - nil))) - (t - (let ((*standard-output* - (if (or (eq destination 't) - (and (synonym-stream-p destination) - (eq (synonym-stream-symbol destination) - '*standard-output*))) - *standard-output* - destination))) - (let ((errorp (catch 'format-error - (catch 'format-escape - (catch 'format-colon-escape - (sub-format 0 (length *format-control-string*)))) - nil))) - (when errorp - (error "~%~:{~@?~%~}" (nreverse errorp)))) - nil))))) - -;;;; SUB-FORMAT, the real work of FORMAT. - -;;; This function does the real work of format. The segment of the control -;;; string between indiced START (inclusive) and END (exclusive) is processed -;;; as follows: Text not part of a directive is output without further -;;; processing. Directives are parsed along with their parameters and flags, -;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and -;;; PARMS. -;;; -;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION stream operation -;;; for speed. This is potentially faster than character-at-a-time searching. - -(defun sub-format (start end) - (declare (fixnum start end)) - (let ((*format-index* start) - (*format-length* end)) - (declare (fixnum *format-index* *format-length*)) - (do* ((place start *format-index*) - (tilde (format-find-char #\~ start end) - (format-find-char #\~ place end))) - ((not tilde) - (write-string *format-control-string* *standard-output* - :start place :end end)) - (declare (fixnum place) (type (or fixnum null) tilde)) - (when (> tilde place) - (write-string *format-control-string* *standard-output* - :start place :end tilde)) - (setq *format-index* tilde) - (multiple-value-bind - (parms colon atsign command) - (parse-format-operation) - (let ((cmdfun (svref *format-dispatch-table* (char-code command)))) - (if cmdfun - (funcall cmdfun colon atsign parms) - (format-error "Illegal FORMAT command ~~~S" command)))) - (unless (< (the fixnum (incf (the fixnum *format-index*))) end) - (return))))) +;;;; - - -;;;; Conditional case conversion ~( ... ~) - -(defun format-capitalization (colon atsign parms) - (when parms - (format-error "No parameters allowed to ~~(")) - (nextchar) - (multiple-value-bind - (prev tilde end-parms end-colon end-atsign) - (format-find-command '(#\))) - (when (or end-parms end-colon end-atsign) - (format-error "Flags or parameters not allowed")) - (let ((string (format-stringify-output (sub-format prev tilde)))) - (declare (string string)) - (write-string - (cond ((and atsign colon) - (nstring-upcase string)) - (colon - (nstring-capitalize string)) - (atsign - (let ((strlen (length string))) - (declare (fixnum strlen)) - ;; Capitalize the first word only - (nstring-downcase string) - (do ((i 0 (1+ i))) - ((or (<= strlen i) (alpha-char-p (char string i))) - (setf (char string i) (char-upcase (char string i))) +(defun expand-control-string (string) + (let* ((string (etypecase string + (simple-string string) - (declare (fixnum i))))) - (t (nstring-downcase string))))))) - - - -;;; Up and Out (Escape) ~^ - -(defun format-escape (colon atsign parms) - (when atsign - (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon)) - (when (if (first parms) - (if (second parms) - (if (third parms) - (typecase (second parms) - (integer - (<= (first parms) (second parms) (third parms))) - (character - (char< (first parms) (second parms) (third parms))) - (t nil)) - (equal (first parms) (second parms))) - (zerop (first parms))) - (not *format-arguments*)) - (throw (if colon 'format-colon-escape 'format-escape) nil))) - - -;;;; Conditional expression ~[ ... ] - - -;;; ~[ - -(defun format-untagged-condition () - (let ((test (pop-format-arg))) - (unless (integerp test) - (format-error "Argument to ~~[ must be integer - ~S" test)) - (do ((count 0 (1+ count))) - ((= count test) - (multiple-value-bind - (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\])) - (declare (ignore colon)) - (when atsign - (format-error "Atsign flag not allowed")) - (when parms - (format-error "No parameters allowed")) - (sub-format prev tilde) - (unless (char= cmd #\]) - (format-find-command '(#\]))))) + (string + (coerce string 'simple-string)))) + (*default-format-error-control-string* string) + (directives (tokenize-control-string string))) + `(let ((*default-format-error-control-string* ',string)) + (block nil + (macrolet ((next-arg () + '(if args + (pop args) + (error 'format-error + :complaint + "No more arguments to satisfy directive.")))) + ,@(expand-directive-list directives)))))) + +(defun expand-directive-list (directives) + (let ((results nil) + (remaining-directives directives)) + (loop + (unless remaining-directives + (return)) (multiple-value-bind - (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\])) - (declare (ignore prev tilde)) - (when atsign - (format-error "Atsign flag not allowed")) - (when parms - (format-error "Parameters not allowed")) - (when (char= cmd #\]) (return)) - (when colon - (nextchar) - (multiple-value-bind (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\])) - (declare (ignore parms colon atsign)) - (sub-format prev tilde) - (unless (char= cmd #\]) - (format-find-command '(#\])))) - (return)) - (nextchar))))) - - -;;; ~@[ - -(defun format-funny-condition () - (multiple-value-bind - (prev tilde parms colon atsign) - (format-find-command '(#\])) - (when (or colon atsign parms) - (format-error "Flags or arguments not allowed")) - (if *format-arguments* - (if (car *format-arguments*) - (sub-format prev tilde) - (pop *format-arguments*)) - (format-error "Missing argument")))) - - -;;; ~:[ - -(defun format-boolean-condition () - (multiple-value-bind - (prev tilde parms colon atsign) - (format-find-command '(#\;)) - (when (or parms colon atsign) - (format-error "Flags or parameters not allowed")) - (nextchar) - (if (pop-format-arg) - (multiple-value-bind - (prev tilde parms colon atsign) - (format-find-command '(#\])) - (when (or colon atsign parms) - (format-error "Flags or parameters not allowed")) - (sub-format prev tilde)) - (progn - (sub-format prev tilde) - (format-find-command '(#\])))))) - - -(defun format-condition (colon atsign parms) - (when parms - (push (pop parms) *format-arguments*) - (unless (null parms) - (format-error "Too many parameters to ~["))) - (nextchar) - (cond (colon - (when atsign - (format-error "~~:@[ undefined")) - (format-boolean-condition)) - (atsign - (format-funny-condition)) - (t (format-untagged-condition)))) - - -;;;; Iteration ~{ ... ~} - -(defun format-iteration (colon atsign parms) - (with-format-parameters parms ((max-iter -1)) - (nextchar) - (multiple-value-bind - (prev tilde end-parms end-colon end-atsign) - (format-find-command '(#\})) - (when (or end-atsign end-parms) - (format-error "Illegal terminator for ~~{")) - (if (= prev tilde) - ;; Use an argument as the control string if ~{~} is empty - (let ((string (pop-format-arg))) - (unless (stringp string) - (format-error "Control string is not a string")) - (format-with-control-string string - (format-do-iteration 0 *format-length* - max-iter colon atsign end-colon))) - (format-do-iteration prev tilde max-iter colon atsign end-colon))))) - - -;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here -;;; to correctly implement ~^ and ~:^. The former aborts only the current -;;; iteration, but the latter aborts the entire iteration process. - -(defun format-do-iteration (start end max-iter colon atsign at-least-once-p) - (catch 'format-colon-escape - (catch 'format-escape - (if atsign - (do* ((count 0 (1+ count))) - ((or (= count max-iter) - (and (null *format-arguments*) - (if (= count 0) (not at-least-once-p) t)))) - (catch 'format-escape - (if colon - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list")) - (sub-format start end)) - (sub-format start end)))) - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list")) - (do* ((count 0 (1+ count))) - ((or (= count max-iter) - (and (null *format-arguments*) - (if (= count 0) (not at-least-once-p) t)))) - (catch 'format-escape - (if colon - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list of lists")) - (sub-format start end)) - (sub-format start end))))))))) - - - -;;;; Justification ~< ... ~> - -;;; Parses a list of clauses delimited by ~; and terminated by ~>. -;;; Recursively invoke SUB-FORMAT to process them, and return a list -;;; of the results, the length of this list, and the total number of -;;; characters in the strings composing the list. - -(defun format-get-trailing-segments () - (nextchar) - (multiple-value-bind - (prev tilde colon atsign parms cmd) - (format-find-command '(#\; #\>)) - (when colon - (format-error "~~:; allowed only after first segment in ~~<")) - (when (or atsign parms) - (format-error "Flags and parameters not allowed")) - (let ((str (catch 'format-escape - (format-stringify-output (sub-format prev tilde))))) - (declare (type (or string null) str)) - (if str - (if (char= cmd #\;) + (form new-directives) + (expand-directive (car remaining-directives) + (cdr remaining-directives)) + (push form results) + (setf remaining-directives new-directives))) + (reverse results))) + +(defun expand-directive (directive more-directives) + (etypecase directive + (format-directive + (let ((expander + (aref *format-directive-expanders* + (char-code (format-directive-character directive))))) + (if expander + (let ((*default-format-error-offset* + (1- (format-directive-end directive)))) (multiple-value-bind - (segments numsegs numchars) - (format-get-trailing-segments) - (values (cons str segments) - (1+ numsegs) (+ numchars (length str)))) - (values (list str) 1 (length str))) - (values () 0 0))))) - - -;;; Gets the first segment, which is treated specially. Call -;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest. - -(defun format-get-segments () - (multiple-value-bind - (prev tilde parms colon atsign cmd) - (format-find-command '(#\; #\>)) - (when atsign - (format-error "Atsign flag not allowed")) - (let ((first-seg (format-stringify-output (sub-format prev tilde)))) - (if (char= cmd #\;) - (multiple-value-bind - (segments numsegs numchars) - (format-get-trailing-segments) - (if colon - (values first-seg parms segments numsegs numchars) - (values nil nil (cons first-seg segments) (1+ numsegs) - (+ (length first-seg) numchars)))) - (values nil nil (list first-seg) 1 (length first-seg)))))) - - - - -;;;; Padding functions for Justification. + (form directives) + (funcall expander directive more-directives) + (values `(let ((*default-format-error-offset* + ',(1- (format-directive-end directive)))) + ,form) + directives))) + (error 'format-error + :complaint "Unknown directive." + :control-string (format-directive-string directive) + :offset (1- (format-directive-end directive)))))) + (simple-string + (values `(write-string ,directive stream) + more-directives)))) -;;; Given the total number of SPACES needed for padding, and the number -;;; of padding segments needed (PADDINGS), returns a list of such segments. -;;; We try to allocate the spaces equally to each segment. When this is -;;; not possible, allocate any left over spaces to the first segment. -;;; -(defun make-pad-segs (spaces padding-segs) - (do* ((extra-space () (and (plusp extra-spaces) - extra-inc - (zerop (rem segs extra-inc)))) - (result () (cons (cond ((= segs 1) (+ min-space extra-spaces)) - (extra-space (1+ min-space)) - (t min-space)) - result)) - (min-space (truncate spaces padding-segs)) - (extra-spaces (- spaces (* padding-segs min-space)) - (if extra-space - (1- extra-spaces) extra-spaces)) - (extra-inc (if (plusp extra-spaces) - (truncate spaces extra-spaces))) - (segs padding-segs (1- segs))) - ((zerop segs) result))) - - -;;; Determine the actual width to be used for a field requiring WIDTH -;;; characters according to the following rule: If WIDTH is less than or -;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up -;;; to MINCOL + k * COLINC for the smallest possible positive integer k. -;;; -(defun format-round-columns (width mincol colinc) - (if (> width mincol) - (multiple-value-bind - (quotient remainder) - (floor (- width mincol) colinc) - (+ mincol (* quotient colinc) (if (zerop remainder) 0 colinc))) - mincol)) - - - -(defun format-justification (colon atsign parms) - (with-format-parameters parms - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - (unless (and (integerp mincol) (not (minusp mincol))) - (format-error "Mincol must be a non-negative integer - ~S" mincol)) - (unless (and (integerp colinc) (plusp colinc)) - (format-error "Colinc must be a positive integer - ~S" colinc)) - (unless (and (integerp minpad) (not (minusp minpad))) - (format-error "Minpad must be a non-negative integer - ~S" minpad)) - (unless (characterp padchar) - (format-error "Padchar must be a character - ~S" padchar)) - (nextchar) - (multiple-value-bind - (special-arg special-parms segments numsegs numchars) - (format-get-segments) - (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0) - (1- numsegs) - (if (and atsign (or (/= numsegs 1) colon)) - 1 0))) - (width (format-round-columns (+ numchars (* minpad padsegs)) - mincol colinc)) - (spaces (append (if (or colon (= numsegs 1)) () '(0)) - (make-pad-segs (- width numchars) padsegs) - (if (and atsign (or (/= numsegs 1) colon)) - () '(0))))) - (when special-arg - (with-format-parameters special-parms ((spare 0) - (linel (or (line-length) 72))) - (let ((pos (or (charpos *standard-output*) 0))) - (when (> (+ pos width spare) linel) - (write-string special-arg))))) - (cond ((and atsign (= numsegs 1) (not colon)) - (write-string (car segments)) - (dotimes (i (car spaces)) (write-char padchar))) - (t - (do ((segs segments (cdr segs)) - (spcs spaces (cdr spcs))) - ((null segs) (dotimes (i (car spcs)) (write-char padchar))) - (dotimes (i (car spcs)) (write-char padchar)) - (write-string (car segs))))))))) -;;;; Newline ~& - -(defun format-terpri (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (dotimes (i repeat-count) (terpri)))) - - -;;; Fresh-line ~% - -(defun format-freshline (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (fresh-line) - (dotimes (i (1- repeat-count)) (terpri)))) - - -;;; Page ~| - -(defun format-page (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (dotimes (i repeat-count) (write-char #\form)))) - - -;;; Print a tilde ~~ - -(defun format-tilde (colon atsign parms) - (when (or colon atsign) - (format-error "Flags not allowed")) - (with-format-parameters parms ((repeat-count 1)) - (dotimes (i repeat-count) (write-char #\~)))) - +;;;; Format directive definition macros and runtime support. + +(eval-when (compile eval) + +(defmacro def-complex-format-directive (char lambda-list &body body) + (let ((defun-name (intern (format nil "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" + char))) + (directive (gensym)) + (directives (if lambda-list (car (last lambda-list)) (gensym)))) + `(progn + (defun ,defun-name (,directive ,directives) + ,@(if lambda-list + `((let ,(mapcar #'(lambda (var) + `(,var + (,(intern (concatenate + 'string + "FORMAT-DIRECTIVE-" + (symbol-name var)) + (symbol-package 'foo)) + ,directive))) + (butlast lambda-list)) + ,@body)) + `((declare (ignore ,directive ,directives)) + ,@body))) + (%set-format-directive-expander ,char #',defun-name)))) + +(defmacro def-format-directive (char lambda-list &body body) + (let ((directives (gensym)) + (declarations nil) + (body-without-decls body)) + (loop + (let ((form (car body-without-decls))) + (unless (and (consp form) (eq (car form) 'declare)) + (return)) + (push (pop body-without-decls) declarations))) + (setf declarations (reverse declarations)) + `(def-complex-format-directive ,char (,@lambda-list ,directives) + ,@declarations + (values (progn ,@body-without-decls) + ,directives)))) + +(defmacro bind-defaults (specs params &body body) + (once-only ((params params)) + (collect ((expander-bindings) (runtime-bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (let ((symbol (gensym))) + (expander-bindings + `(,var ',symbol)) + (runtime-bindings + `(list ',symbol + (let ((param (pop ,params))) + (case param + (:arg `(or (next-arg) ,,default)) + (:remaining '(length args)) + ((nil) ,default) + (t param)))))))) + `(let ,(expander-bindings) + `(let ,(list ,@(runtime-bindings)) + ,@(if ,params + (error 'format-error + :complaint + "Too many parameters, expected no more than ~D" + :arguments (list ,(length specs)))) + ,,@body)))))) + +); eval-when + +(defun %set-format-directive-expander (char fn) + (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) + char) + +(defun find-directive (directives kind stop-at-semi) + (if directives + (let ((next (car directives))) + (if (format-directive-p next) + (let ((char (format-directive-character next))) + (if (or (char= kind char) + (and stop-at-semi (char= char #\;))) + (car directives) + (find-directive + (cdr (flet ((after (char) + (member (find-directive (cdr directives) + char + nil) + directives))) + (case char + (#\( (after #\))) + (#\< (after #\>)) + (#\[ (after #\])) + (#\{ (after #\})) + (t directives)))) + kind stop-at-semi))) + (find-directive (cdr directives) kind stop-at-semi))))) + +(defvar *up-up-and-out-allowed* nil) -;;; Continue control string on next line ~<newline> -(defun format-eat-whitespace () - (nextchar) - (setq *format-index* - (1- (the fixnum - (position-if-not #'(lambda (ch) (or (whitespace-char-p ch) - (char= ch #\linefeed))) - (the simple-string *format-control-string*) - :start *format-index*))))) - - -(defun format-newline (colon atsign parms) - (when parms - (format-error "Parameters not allowed")) - (cond (colon - (when atsign (format-error "~:@<newline> is undefined"))) - (atsign (terpri)(format-eat-whitespace)) - (t (format-eat-whitespace)))) - - -;;;; Pluralize word (~P) and Skip Arguments (~*) - -(defun format-plural (colon atsign parms) - (when parms - (format-error "Parameters not allowed")) - (when colon - ;; Back up one argument first - (let ((cdrs (- (length (the list *format-original-arguments*)) - (length (the list *format-arguments*)) - 1))) - (if (minusp cdrs) - (format-error "No previous argument") - (setq *format-arguments* - (nthcdr cdrs *format-original-arguments*))))) - (if (eql (pop-format-arg) 1) - (write-string (if atsign "y" "")) - (write-string (if atsign "ies" "s")))) - - - -;;; Skip arguments (relative goto) ~* - -(defun format-skip-arguments (colon atsign parms) - (cond (atsign - (with-format-parameters parms ((count 0)) - (when (or (minusp count) - (> count (length *format-original-arguments*))) - (format-error "Illegal to go to non-existant argument")) - (setq *format-arguments* - (nthcdr count *format-original-arguments*)))) - (colon - (with-format-parameters parms ((count 1)) - (let ((cdrs (- (length (the list *format-original-arguments*)) - (length (the list *format-arguments*)) - count))) - (if (minusp cdrs) - (format-error "Skip to nonexistant argument") - (setq *format-arguments* - (nthcdr cdrs *format-original-arguments*)))))) - (t - (with-format-parameters parms ((count 1)) - (if (> count (length *format-arguments*)) - (format-error "Skip to nonexistant argument") - (setq *format-arguments* (nthcdr count *format-arguments*))))))) - - -;;;; Indirection ~? - -(defun format-indirection (colon atsign parms) - (if (or colon parms) (format-error "Colon flag or parameters not allowed")) - (let ((string (pop-format-arg))) - (unless (stringp string) - (format-error "Indirected control string is not a string")) - (format-with-control-string string - (if atsign - (sub-format 0 *format-length*) - (let* ((*format-original-arguments* (pop-format-arg)) - (*format-arguments* *format-original-arguments*)) - (unless (listp *format-arguments*) - (format-error "Argument must be a list")) - (sub-format 0 *format-length*)))))) - - - -;;; Tabulation ~T - -(defun format-tab (colon atsign parms) - (with-format-parameters parms ((colnum 1) (colinc 1)) - (when colon - (format-error "Tab-to in pixel units not supported")) - (let* ((pos (charpos *standard-output*)) - (len (cond (pos (let ((col (if atsign (+ pos colnum) colnum))) - (if (> pos col) - (- colinc (rem (- pos col) colinc)) - (- col pos)))) - (atsign colnum) - (t 2)))) - (declare (fixnum len)) - (do ((i len (- i 40))) - ((<= i 40) (write-string " " - *standard-output* :start 0 :end i)) - (declare (fixnum i)) - (write-string " " - *standard-output* - :start 0 - :end 40))))) - -;;;; Ascii ~A - -(defun format-princ (colon atsign parms) - (let ((arg (pop-format-arg))) - (if (null parms) - (if arg (princ arg) (write-string (if colon "()" "NIL"))) - (with-format-parameters parms - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - (format-write-field (if arg - (princ-to-string arg) - (if colon "()" "NIL")) - mincol colinc minpad padchar atsign))))) - - - -;;; S-expression ~S - -(defun format-prin1 (colon atsign parms) - (let ((arg (pop-format-arg))) - (if (null parms) - (if arg (prin1 arg) (write-string (if colon "()" "NIL"))) - (with-format-parameters parms - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - (format-write-field (if arg - (prin1-to-string arg) - (if colon "()" "NIL")) - mincol colinc minpad padchar atsign))))) - - - -;;; Character ~C - -(defun format-print-character (colon atsign parms) - (with-format-parameters parms () - (let ((char (pop-format-arg))) - (unless (characterp char) - (format-error "Argument must be a character")) - (cond (colon - (format-print-named-character char)) - (atsign - (prin1 char)) - (t - (write-char char)))))) - -(defun format-print-named-character (char) - (let* ((name (char-name char))) - (cond (name (write-string (string-capitalize name))) - ;; Print control characters as "^"<char> - ((<= 0 (the fixnum (char-code char)) 31) - (write-char #\^) - (write-char (code-char (+ 64 (the fixnum (char-code char)))))) - (t (write-char char))))) - -;;;; NUMERIC PRINTING - -;;; Insert commas after every third digit, scanning from right to left. - -(defun format-add-commas (string commachar) - (do* ((length (length (the string string))) - (new-length (+ length - (the fixnum (floor (the fixnum (1- length)) 3)))) - (new-string (make-string new-length :initial-element commachar) - (replace (the string new-string) - (the string string) - :start1 (max 0 (- new-pos 3)) - :end1 new-pos - :start2 (max 0 (- pos 3)) - :end2 pos)) - (pos length (- pos 3)) - (new-pos new-length (- new-pos 4))) - ((minusp pos) new-string) - (declare (fixnum length new-length pos new-pos)))) - - -;;; Output a string in a field at MINCOL wide, padding with PADCHAR. -;;; Pads on the left if PADLEFT is true, else on the right. If the -;;; length of the string plus the minimum permissible padding, MINPAD, -;;; is greater than MINCOL, the actual field size is rounded up to -;;; MINCOL + k * COLINC for the smallest possible positive integer k. - -(defun format-write-field (string mincol colinc minpad padchar padleft) - (unless (and (integerp mincol) (not (minusp mincol))) - (format-error "Mincol must be a non-negative integer - ~S" mincol)) - (unless (and (integerp colinc) (plusp colinc)) - (format-error "Colinc must be a positive integer - ~S" colinc)) - (unless (and (integerp minpad) (not (minusp minpad))) - (format-error "Minpad must be a non-negative integer - ~S" minpad)) - (unless (characterp padchar) - (format-error "Padchar must be a character - ~S" padchar)) - (let* ((strlen (length (the string string))) - (width (format-round-columns (+ strlen minpad) mincol colinc))) - (cond (padleft - (dotimes (i (- width strlen)) (write-char padchar)) - (write-string string)) - (t - (write-string string) - (dotimes (i (- width strlen)) (write-char padchar)))))) - +;;;; Utility functions for outputting stuff. + +(defun format-write-field (stream string mincol colinc minpad padchar padleft) + (unless padleft + (write-string string stream)) + (dotimes (i minpad) + (write-char padchar stream)) + (do ((chars (+ (length string) minpad) (+ chars colinc))) + ((>= chars mincol)) + (dotimes (i colinc) + (write-char padchar stream))) + (when padleft + (write-string string stream))) ;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing ;;; directives. The parameters are interpreted as defined for ~D. ;;; -(defun format-print-number (number radix print-commas-p print-sign-p parms) - (with-format-parameters parms - ((mincol 0) (padchar #\space) (commachar #\,)) - (let ((*print-base* radix)) - (if (integerp number) - (let* ((text (princ-to-string (abs number))) - (commaed (if print-commas-p - (format-add-commas text commachar) - text)) - (signed (cond ((minusp number) - (concatenate 'string "-" commaed)) - (print-sign-p - (concatenate 'string "+" commaed)) - (t commaed)))) - ;; colinc = 1, minpad = 0, padleft = t - (format-write-field signed mincol 1 0 padchar t)) - (princ number))))) - - -;;;; Print a cardinal number in English - - -;;; The following are initialized in FORMAT-INIT to get around cold-loader -;;; lossage. - -(defvar cardinal-ones () "Table of cardinal ones-place digits in English") - -(defvar cardinal-tens () "Table of cardinal tens-place digits in English") - -(defvar cardinal-teens () "Table of cardinal 'teens' digits in English") - - -(defun format-print-small-cardinal (n) - (multiple-value-bind - (hundreds rem) (truncate n 100) - (when (plusp hundreds) - (write-string (svref cardinal-ones hundreds)) - (write-string " hundred") - (when (plusp rem) (write-char #\space))) ; ; ; RAD - (when (plusp rem) - (multiple-value-bind (tens ones) - (truncate rem 10) - (cond ((< 1 tens) - (write-string (svref cardinal-tens tens)) - (when (plusp ones) - (write-char #\-) - (write-string (svref cardinal-ones ones)))) - ((= tens 1) - (write-string (svref cardinal-teens ones))) - ((plusp ones) - (write-string (svref cardinal-ones ones)))))))) - - -(defvar cardinal-periods () "Table of cardinal 'illions' in English") - - -(defun format-print-cardinal (n) - (cond ((minusp n) - (write-string "negative ") - (format-print-cardinal-aux (- n) 0 n)) - ((zerop n) - (write-string "zero")) - (t (format-print-cardinal-aux n 0 n)))) - -(defun format-print-cardinal-aux (n period err) - (multiple-value-bind (beyond here) (truncate n 1000) - (unless (<= period 10) - (format-error "Number too large to print in English: ~:D" err)) - (unless (zerop beyond) - (format-print-cardinal-aux beyond (1+ period) err)) - (unless (zerop here) - (unless (zerop beyond) (write-char #\space)) - (format-print-small-cardinal here) - (write-string (svref cardinal-periods period))))) - - -;;;; Print an ordinal number in English - - -(defvar ordinal-ones () "Table of ordinal ones-place digits in English") - -(defvar ordinal-tens () "Table of ordinal tens-place digits in English") - - -(defun format-print-ordinal (n) - (when (minusp n) - (write-string "negative ")) - (let ((number (abs n))) - (multiple-value-bind - (top bot) (truncate number 100) - (unless (zerop top) (format-print-cardinal (- number bot))) - (when (and (plusp top) (plusp bot)) (write-char #\space)) - (multiple-value-bind - (tens ones) (truncate bot 10) - (cond ((= bot 12) (write-string "twelfth")) - ((= tens 1) - (write-string (svref cardinal-teens ones));;;RAD - (write-string "th")) - ((and (zerop tens) (plusp ones)) - (write-string (svref ordinal-ones ones))) - ((and (zerop ones)(plusp tens)) - (write-string (svref ordinal-tens tens))) - ((plusp bot) - (write-string (svref cardinal-tens tens)) - (write-char #\-) - (write-string (svref ordinal-ones ones))) - ((plusp number) (write-string "th")) - (t (write-string "zeroeth"))))))) - - -;;; Print Roman numerals - -(defun format-print-old-roman (n) - (unless (< 0 n 5000) - (format-error "Number too large to print in old Roman numerals: ~:D" n)) - (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) - (val-list '(500 100 50 10 5 1) (cdr val-list)) - (cur-char #\M (car char-list)) - (cur-val 1000 (car val-list)) - (start n (do ((i start (progn (write-char cur-char) (- i cur-val)))) - ((< i cur-val) i)))) - ((zerop start)))) - - -(defun format-print-roman (n) - (unless (< 0 n 4000) - (format-error "Number too large to print in Roman numerals: ~:D" n)) - (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) - (val-list '(500 100 50 10 5 1) (cdr val-list)) - (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) - (sub-val '(100 10 10 1 1 0) (cdr sub-val)) - (cur-char #\M (car char-list)) - (cur-val 1000 (car val-list)) - (cur-sub-char #\C (car sub-chars)) - (cur-sub-val 100 (car sub-val)) - (start n (do ((i start (progn (write-char cur-char) (- i cur-val)))) - ((< i cur-val) - (cond ((<= (- cur-val cur-sub-val) i) - (write-char cur-sub-char) - (write-char cur-char) - (- i (- cur-val cur-sub-val))) - (t i)))))) - ((zerop start)))) +(defun format-print-integer (number stream print-commas-p print-sign-p + radix mincol padchar commachar commainterval) + (let ((*print-base* radix) + (*print-radix* nil)) + (if (integerp number) + (let* ((text (princ-to-string (abs number))) + (commaed (if print-commas-p + (format-add-commas text commachar commainterval) + text)) + (signed (cond ((minusp number) + (concatenate 'string "-" commaed)) + (print-sign-p + (concatenate 'string "+" commaed)) + (t commaed)))) + ;; colinc = 1, minpad = 0, padleft = t + (format-write-field stream signed mincol 1 0 padchar t)) + (princ number)))) + +(defun format-add-commas (string commachar commainterval) + (let ((length (length string))) + (multiple-value-bind (commas extra) + (truncate (1- length) commainterval) + (let ((new-string (make-string (+ length commas))) + (first-comma (1+ extra))) + (replace new-string string :end1 first-comma :end2 first-comma) + (do ((src first-comma (+ src commainterval)) + (dst first-comma (+ dst commainterval 1))) + ((= src length)) + (setf (schar new-string dst) commachar) + (replace new-string string :start1 (1+ dst) + :start2 src :end2 (+ src commainterval))) + new-string)))) -;;;; Format Radix Options (~D ~B ~O ~X ~R). - -;;; Decimal ~D - -(defun format-print-decimal (colon atsign parms) - (format-print-number (pop-format-arg) 10 colon atsign parms)) - - -;;; Binary ~B - -(defun format-print-binary (colon atsign parms) - (format-print-number (pop-format-arg) 2 colon atsign parms)) - - -;;; Octal ~O - -(defun format-print-octal (colon atsign parms) - (format-print-number (pop-format-arg) 8 colon atsign parms)) - - -;;; Hexadecimal ~X - -(defun format-print-hexadecimal (colon atsign parms) - (format-print-number (pop-format-arg) 16 colon atsign parms)) - - -;;; Radix ~R - -(defun format-print-radix (colon atsign parms) - (let ((number (pop-format-arg))) - (if parms - (format-print-number number (pop parms) colon atsign parms) - (if atsign - (if colon - (format-print-old-roman number) - (format-print-roman number)) - (if colon - (format-print-ordinal number) - (format-print-cardinal number)))))) - - -;;;; FLOATING-POINT NUMBERS - -;;; Fixed-format floating point ~F -;;; -(defun format-fixed (colon atsign parms) - (when colon - (format-error "Colon flag not allowed")) - (with-format-parameters parms - ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) - ;;Note that the scale factor k defaults to nil. This is interpreted as - ;;zero by flonum-to-string, but more efficiently. - (let ((number (pop-format-arg))) - (if (floatp number) - (format-fixed-aux number w d k ovf pad atsign) - (if (rationalp number) - (format-fixed-aux - (coerce number 'single-float) w d k ovf pad atsign) - (let ((*print-base* 10)) - (format-write-field - (princ-to-string number) w 1 0 #\space t))))))) +;;;; The actual format directives. + +(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) + (format-write-field stream + (if (or arg (not colonp)) + (princ-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) + +(def-format-directive #\A (colonp atsignp params) + (if params + (bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + `(format-princ stream (next-arg) ',colonp ',atsignp + ,mincol ,colinc ,minpad ,padchar)) + `(princ ,(if colonp '(or (next-arg) "()") '(next-arg)) stream))) + +(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) + (format-write-field stream + (if (or arg (not colonp)) + (prin1-to-string arg) + "()") + mincol colinc minpad padchar atsignp)) + +(def-format-directive #\S (colonp atsignp params) + (cond (params + (bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + `(format-prin1 stream (next-arg) ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))) + (colonp + `(let ((arg (next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + '(prin1 (next-arg) stream)))) + +(defun expand-format-integer (base colonp atsignp params) + (if (or colonp atsignp params) + (bind-defaults + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + `(format-print-integer stream (next-arg) ,colonp ,atsignp ,base ,mincol + ,padchar ,commachar ,commainterval)) + `(write (next-arg) :stream stream :base ,base :radix nil :escape nil))) + +(def-format-directive #\D (colonp atsignp params) + (expand-format-integer 10 colonp atsignp params)) + +(def-format-directive #\B (colonp atsignp params) + (expand-format-integer 2 colonp atsignp params)) + +(def-format-directive #\O (colonp atsignp params) + (expand-format-integer 8 colonp atsignp params)) + +(def-format-directive #\X (colonp atsignp params) + (expand-format-integer 16 colonp atsignp params)) + +(def-format-directive #\R (colonp atsignp params) + (if params + (bind-defaults + ((base 10) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + `(format-print-integer stream (next-arg) ,colonp ,atsignp ,base ,mincol + ,padchar ,commachar ,commainterval)) + (if atsignp + (if colonp + '(format-print-old-roman stream (next-arg)) + '(format-print-roman stream (next-arg))) + (if colonp + '(format-print-ordinal stream (next-arg)) + '(format-print-cardinal stream (next-arg)))))) + +(def-format-directive #\P (colonp atsignp params) + (bind-defaults () params + (let ((arg (if colonp + '(if (eq orig-args args) + (error 'format-error + :complaint "No previous argument.") + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr)))) + '(next-arg)))) + (if atsignp + `(write-string (if (eql ,arg 1) "y" "ies") stream) + `(unless (eql ,arg 1) (write-char #\s stream)))))) + +(defun format-print-named-character (char stream) + (let* ((name (char-name char))) + (cond (name + (write-string (string-capitalize name) stream)) + ((<= 0 (char-code char) 31) + ;; Print control characters as "^"<char> + (write-char #\^ stream) + (write-char (code-char (+ 64 (char-code char))) stream)) + (t + (write-char char stream))))) + +(def-format-directive #\C (colonp atsignp params) + (bind-defaults () params + (if colonp + '(format-print-named-character (next-arg) stream) + (if atsignp + '(prin1 (next-arg) stream) + '(write-char (next-arg) stream))))) + +(def-format-directive #\F (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params + `(format-fixed stream (next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) + +(defun format-fixed (stream number w d k ovf pad atsign) + (if (floatp number) + (format-fixed-aux stream number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux stream + (coerce number 'single-float) + w d k ovf pad atsign) + (let ((*print-base* 10)) + (format-write-field stream + (princ-to-string number) + w 1 0 #\space t))))) ;;; We return true if we overflowed, so that ~G can output the overflow char ;;; instead of spaces. ;;; -(defun format-fixed-aux (number w d k ovf pad atsign) +(defun format-fixed-aux (stream number w d k ovf pad atsign) (cond ((not (or w d)) - (prin1 number) + (prin1 number stream) nil) (t (let ((spaceleft w)) (when (and w (or atsign (minusp number))) (decf spaceleft)) (multiple-value-bind (str len lpoint tpoint) - (flonum-to-string (abs number) spaceleft d k) + (lisp::flonum-to-string (abs number) spaceleft d k) ;;if caller specifically requested no fraction digits, suppress the ;;optional trailing zero (when (and d (zerop d)) (setq tpoint nil)) @@ -1256,37 +599,39 @@ (setq tpoint nil)))) (cond ((and w (< spaceleft 0) ovf) ;;field width overflow - (dotimes (i w) (write-char ovf)) + (dotimes (i w) (write-char ovf stream)) t) (t - (when w (dotimes (i spaceleft) (write-char pad))) + (when w (dotimes (i spaceleft) (write-char pad stream))) (if (minusp number) - (write-char #\-) - (if atsign (write-char #\+))) - (when lpoint (write-char #\0)) - (write-string str) - (when tpoint (write-char #\0)) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string str stream) + (when tpoint (write-char #\0 stream)) nil))))))) - -;;;; Exponential-format floating point ~E - - -(defun format-exponential (colon atsign parms) - (when colon - (format-error "Colon flag not allowed")) - (with-format-parameters parms - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) - (let ((number (pop-format-arg))) - (if (floatp number) - (format-exp-aux number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-exp-aux - (coerce number 'single-float) w d e k ovf pad marker atsign) - (let ((*print-base* 10)) - (format-write-field - (princ-to-string number) w 1 0 #\space t))))))) - +(def-format-directive #\E (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (bind-defaults + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) + params + `(format-exponent stream (next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) + +(defun format-exponential (stream number w d e k ovf pad marker atsign) + (if (floatp number) + (format-exp-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field stream + (princ-to-string number) + w 1 0 #\space t))))) (defun format-exponent-marker (number) (if (typep number *read-default-float-format*) @@ -1295,8 +640,7 @@ (single-float #\f) (double-float #\d) (short-float #\s) - (long-float #\L)))) - + (long-float #\l)))) ;;;Here we prevent the scale factor from shifting all significance out of ;;;a number to the right. We allow insignificant zeroes to be shifted in @@ -1305,11 +649,11 @@ ;;;errors. As for now, we let the user get away with it, and merely guarantee ;;;that at least one significant digit will appear. -(defun format-exp-aux (number w d e k ovf pad marker atsign) +(defun format-exp-aux (stream number w d e k ovf pad marker atsign) (if (not (or w d)) - (prin1 number) + (prin1 number stream) (multiple-value-bind (num expt) - (scale-exponent (abs number)) + (lisp::scale-exponent (abs number)) (let* ((expt (- expt k)) (estr (princ-to-string (abs expt))) (elen (if e (max (length estr) e) (length estr))) @@ -1319,62 +663,65 @@ (when (or atsign (minusp number)) (decf spaceleft)) (if (and w e ovf (> elen e)) ;;exponent overflow - (dotimes (i w) (write-char ovf)) - (multiple-value-bind (fstr flen lpoint ) ;(tpoint) - (flonum-to-string num spaceleft fdig k fmin) + (dotimes (i w) (write-char ovf stream)) + (multiple-value-bind + (fstr flen lpoint) + (lisp::flonum-to-string num spaceleft fdig k fmin) (when w (decf spaceleft flen) - ;; (when tpoint (decf spaceleft)) ; deleted as per Rutgers' fix (when lpoint (if (> spaceleft 0) (decf spaceleft) (setq lpoint nil)))) (cond ((and w (< spaceleft 0) ovf) ;;significand overflow - (dotimes (i w) (write-char ovf))) + (dotimes (i w) (write-char ovf stream))) (t (when w - (dotimes (i spaceleft) (write-char pad))) + (dotimes (i spaceleft) (write-char pad stream))) (if (minusp number) - (write-char #\-) - (if atsign (write-char #\+))) - (when lpoint (write-char #\0)) - (write-string fstr) - ;; (when tpoint (write-char #\0)) ; as per Rutgers' fix + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) (write-char (if marker marker - (format-exponent-marker number))) - (write-char (if (minusp expt) #\- #\+)) + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) (when e ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) (write-char #\0))) - (write-string estr))))))))) - + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream))))))))) + +(def-format-directive #\G (colonp atsignp params) + (when colonp + (error 'format-error + :complaint + "Cannot specify the colon modifier with this directive.")) + (bind-defaults + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) + params + `(format-general stream (next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) + +(defun format-general (stream number w d e k ovf pad marker atsign) + ;;The Excelsior edition does not say what to do if + ;;the argument is not a float. Here, we adopt the + ;;conventions used by ~F and ~E. + (if (floatp number) + (format-general-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux stream + (coerce number 'single-float) + w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field stream + (princ-to-string number) + w 1 0 #\space t))))) - -;;;; General Floating Point - ~G - -(defun format-general-float (colon atsign parms) - (when colon - (format-error "Colon flag not allowed")) - (with-format-parameters parms - ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (marker nil)) - (let ((number (pop-format-arg))) - ;;The Excelsior edition does not say what to do if - ;;the argument is not a float. Here, we adopt the - ;;conventions used by ~F and ~E. - (if (floatp number) - (format-general-aux number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-general-aux - (coerce number 'single-float) w d e k ovf pad marker atsign) - (let ((*print-base* 10)) - (format-write-field - (princ-to-string number) w 1 0 #\space t))))))) - - -(defun format-general-aux (number w d e k ovf pad marker atsign) +(defun format-general-aux (stream number w d e k ovf pad marker atsign) (multiple-value-bind (ignore n) - (scale-exponent (abs number)) + (lisp::scale-exponent (abs number)) (declare (ignore ignore)) ;;Default d if omitted. The procedure is taken directly ;;from the definition given in the manual, and is not @@ -1382,7 +729,7 @@ ;;Future maintainers are encouraged to improve on this. (unless d (multiple-value-bind (str len) - (flonum-to-string (abs number)) + (lisp::flonum-to-string (abs number)) (declare (ignore str)) (let ((q (if (= len 1) 1 (1- len)))) (setq d (max q (min n 7)))))) @@ -1390,120 +737,493 @@ (ww (if w (- w ee) nil)) (dd (- d n))) (cond ((<= 0 dd d) - (let ((char (if (format-fixed-aux number ww dd nil ovf pad - atsign) + (let ((char (if (format-fixed-aux stream number ww dd nil + ovf pad atsign) ovf #\space))) - (dotimes (i ee) (write-char char)))) + (dotimes (i ee) (write-char char stream)))) (t - (format-exp-aux number w d e (or k 1) ovf pad marker atsign)))))) - - -;;; Dollars floating-point format ~$ - -(defun format-dollars (colon atsign parms) - (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) - (let ((number (pop-format-arg))) - (if (rationalp number) (setq number (coerce number 'single-float))) - (if (floatp number) - (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) - (signlen (length signstr))) - (multiple-value-bind (str strlen ig2 ig3 pointplace) - (flonum-to-string number nil d nil) - (declare (ignore ig2 ig3)) - (when colon (write-string signstr)) - (dotimes (i (- w signlen (- n pointplace) strlen)) - (write-char pad)) - (unless colon (write-string signstr)) - (dotimes (i (- n pointplace)) (write-char #\0)) - (write-string str))) - (let ((*print-base* 10)) - (format-write-field (princ-to-string number) w 1 0 #\space t)))))) - - -;;;; INITIALIZATION - - -;;; Hairy dispatch-table initialization macro. Takes a list of two-element -;;; lists (<character> <function-object>) and returns a vector char-code-limit -;;; elements in length, where the Ith element is the function associated with -;;; the character with char-code I. If the character is case-convertible, it -;;; must be given in only one case; however, an entry in the vector will be -;;; made for both. - - -(defmacro make-dispatch-vector (&body entries) - (let ((entries (mapcan #'(lambda (x) - (let ((lower (char-downcase (car x))) - (upper (char-upcase (car x)))) - (if (char= lower upper) - (list x) - (list (cons upper (cdr x)) - (cons lower (cdr x)))))) - entries))) - (do ((entries (sort entries #'(lambda (x y) (char< (car x) (car y))))) - (charidx 0 (1+ charidx)) - (comtab () (cons (if entries - (if (= (char-code (caar entries)) charidx) - (cadr (pop entries)) - nil) - nil) - comtab))) - ((= charidx char-code-limit) - (if entries - (error "Garbage in dispatch vector - ~S" entries)) - `(vector ,@(nreverse comtab)))))) - - - -;;; These initializations properly belong in the DEFVARs for these objects. -;;; At present, they must be done after loading due to a limitation in the -;;; cold loader. - -(defun format-init () - (setf cardinal-ones - '#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) - (setf cardinal-tens - '#(nil nil "twenty" "thirty" "forty" - "fifty" "sixty" "seventy" "eighty" "ninety")) - (setf cardinal-teens - '#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD - "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) - (setf cardinal-periods - '#("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion")) - (setf ordinal-ones - '#(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth")) - (setf ordinal-tens - '#(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) - (setf *format-dispatch-table* - (make-dispatch-vector - (#\B #'format-print-binary) - (#\O #'format-print-octal) - (#\D #'format-print-decimal) - (#\X #'format-print-hexadecimal) - (#\R #'format-print-radix) - (#\F #'format-fixed) - (#\E #'format-exponential) - (#\G #'format-general-float) - (#\A #'format-princ) - (#\C #'format-print-character) - (#\P #'format-plural) - (#\S #'format-prin1) - (#\T #'format-tab) - (#\% #'format-terpri) - (#\& #'format-freshline) - (#\* #'format-skip-arguments) - (#\| #'format-page) - (#\~ #'format-tilde) - (#\$ #'format-dollars) - (#\? #'format-indirection) - (#\^ #'format-escape) - (#\[ #'format-condition) - (#\{ #'format-iteration) - (#\< #'format-justification) - (#\( #'format-capitalization) - (#\newline #'format-newline)))) + (format-exp-aux stream number w d e (or k 1) + ovf pad marker atsign)))))) + +(def-format-directive #\$ (colonp atsignp params) + (bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params + `(format-dollars stream (next-arg) ,d ,n ,w ,pad ,colonp ,atsignp))) + +(defun format-dollars (stream number d n w pad colon atsign) + (if (rationalp number) (setq number (coerce number 'single-float))) + (if (floatp number) + (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) + (signlen (length signstr))) + (multiple-value-bind (str strlen ig2 ig3 pointplace) + (lisp::flonum-to-string number nil d nil) + (declare (ignore ig2 ig3)) + (when colon (write-string signstr stream)) + (dotimes (i (- w signlen (- n pointplace) strlen)) + (write-char pad stream)) + (unless colon (write-string signstr stream)) + (dotimes (i (- n pointplace)) (write-char #\0 stream)) + (write-string str stream))) + (let ((*print-base* 10)) + (format-write-field stream + (princ-to-string number) + w 1 0 #\space t)))) + +(def-format-directive #\% (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (bind-defaults ((count 1)) params + `(dotimes (i ,count) + (terpri stream))) + '(terpri stream))) + +(def-format-directive #\& (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (bind-defaults ((count 1)) params + `(progn + (fresh-line stream) + (dotimes (i (1- ,count)) + (terpri stream)))) + '(fresh-line stream))) + +(def-format-directive #\| (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char #\page stream))) + '(write-char #\page stream))) + +(def-format-directive #\~ (colonp atsignp params) + (when (or colonp atsignp) + (error 'format-error + :complaint + "Cannot specify either colon or atsign for this directive.")) + (if params + (bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char #\~ stream))) + '(write-char #\~ stream))) + +(def-complex-format-directive #\newline (colonp atsignp params directives) + (when (and colonp atsignp) + (error 'format-error + :complaint + "Cannot specify both colon and atsign for this directive.")) + (values (bind-defaults () params + (if atsignp + '(write-char #\newline stream) + nil)) + (if (and (not colonp) + directives + (simple-string-p (car directives))) + (cons (string-left-trim '(#\space #\newline #\tab) + (car directives)) + (cdr directives)) + directives))) + +(def-format-directive #\T (colonp atsignp params) + (if colonp + (bind-defaults ((n 1) (m 1)) params + `(pprint-tab ,(if atsignp :section-relative :section) + ,n ,m stream)) + (if atsignp + (bind-defaults ((colrel 1) (colinc 1)) params + `(format-relative-tab stream ,colrel ,colinc)) + (bind-defaults ((colnum 1) (colinc 1)) params + `(format-absolute-tab stream ,colnum ,colinc))))) + +(def-format-directive #\* (colonp atsignp params) + (if atsignp + (if colonp + (error 'format-error + :complaint "Cannot specify both colon and at-sign.") + (bind-defaults ((posn 0)) params + `(if (<= 0 ,posn (length orig-args)) + (setf args (subseq orig-args ,posn)) + (error 'format-error + :complaint "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments (list ,posn (length orig-args)))))) + (if colonp + (bind-defaults ((n 1)) params + `(do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn ,n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (subseq orig-args new-posn)) + (error 'format-error + :complaint + "Index ~D out of bounds. Should have been ~ + between 0 and ~D." + :arguments + (list new-posn (length orig-args)))))))) + (if params + (bind-defaults ((n 1)) params + `(dotimes (i ,n) + (next-arg))) + '(next-arg))))) + +(def-format-directive #\? (colonp atsignp params) + (when colonp + (error 'format-error + :complaint "Cannot specify the colon modifier.")) + (bind-defaults () params + `(handler-case + ,(if atsignp + '(setf args (%format stream (next-arg) orig-args args)) + '(%format stream (next-arg) (next-arg))) + (format-error (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :arguments (list condition) + :print-banner nil))))) + +(def-format-directive #\_ (colonp atsignp params) + (bind-defaults () params + `(pprint-newline ,(if colonp + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) + +(def-format-directive #\W (colonp atsignp params) + (bind-defaults () params + `(write (next-arg) :stream stream + ,@(when colonp + '(:pretty t)) + ,@(when atsignp + '(:level nil :length nil))))) + +(def-format-directive #\I (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "Cannot specify the at-sign modifier.")) + (bind-defaults ((n 0)) params + `(pprint-indent ,(if colonp :current :block) ,n stream))) + +(def-complex-format-directive #\( (colonp atsignp params directives) + (let ((close (find-directive directives #\) nil))) + (unless close + (error 'format-error + :complaint "No corresponding close paren.")) + (let* ((posn (position close directives)) + (before (subseq directives 0 posn)) + (after (subseq directives (1+ posn)))) + (values + (bind-defaults () params + `(let ((stream (make-case-frob-stream stream + ,(if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + ,@(expand-directive-list before))) + after)))) + +(def-complex-format-directive #\) () + (error 'format-error + :complaint "No corresponding open paren.")) + +(def-complex-format-directive #\[ (colonp atsignp params directives) + (let ((sublists nil) + (last-semi-with-colon-p nil) + (remaining directives)) + (loop + (let ((close-or-semi (find-directive remaining #\] t))) + (unless close-or-semi + (error 'format-error + :complaint "No corresponding close bracket.")) + (let ((posn (position close-or-semi remaining))) + (push (subseq remaining 0 posn) sublists) + (setf remaining (subseq remaining (1+ posn))) + (when (char= (format-directive-character close-or-semi) #\]) + (return)) + (setf last-semi-with-colon-p + (format-directive-colonp close-or-semi))))) + (values + (if atsignp + (if colonp + (error 'format-error + :complaint + "Cannot specify both the colon and at-sign modifiers.") + (if (cdr sublists) + (error 'format-error + :complaint + "Can only specify one section") + (bind-defaults () params + `(let ((prev-args args) + (arg (next-arg))) + (when arg + (setf args prev-args) + ,@(expand-directive-list (car sublists))))))) + (if colonp + (if (= (length sublists) 2) + (bind-defaults () params + `(if (next-arg) + (progn + ,@(expand-directive-list (car sublists))) + (progn + ,@(expand-directive-list (cadr sublists))))) + (error 'format-error + :complaint + "Must specify exactly two sections.")) + (bind-defaults ((index '(next-arg))) params + (let ((clauses nil)) + (when last-semi-with-colon-p + (push `(t ,@(expand-directive-list (pop sublists))) + clauses)) + (let ((count (length sublists))) + (dolist (sublist sublists) + (push `(,(decf count) + ,@(expand-directive-list sublist)) + clauses))) + `(case ,index ,@clauses))))) + remaining))) + +(def-complex-format-directive #\; () + (error 'format-error + :complaint + "~~; not contained within either ~~[...~~] or ~~<...~~>.")) + +(def-complex-format-directive #\] () + (error 'format-error + :complaint + "No corresponding open bracket.")) + +(def-complex-format-directive #\{ (colonp atsignp params directives) + (let ((close (find-directive directives #\} nil))) + (unless close + (error 'format-error + :complaint + "No corresponding close brace.")) + (let* ((closed-with-colon (format-directive-colonp close)) + (posn (position close directives)) + (insides + (if (zerop posn) + `((handler-case + (setf args (%format stream inside-string orig-args args)) + (format-error + (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :arguments (list condition) + :print-banner nil)))) + (let ((*up-up-and-out-allowed* colonp)) + (expand-directive-list (subseq directives 0 posn)))))) + (flet ((compute-loop (count) + `(loop + ,@(unless closed-with-colon + '((when (null args) + (return)))) + ,@(when count + `((when (and ,count (minusp (decf ,count))) + (return)))) + ,@(if colonp + `((let* ((orig-args (next-arg)) + (outside-args args) + (args orig-args)) + (declare (ignorable orig-args outside-args args)) + (block nil + ,@insides))) + insides) + ,@(when closed-with-colon + '((when (null args) + (return))))))) + (let ((loop + (if params + (bind-defaults ((count nil)) params + (compute-loop count)) + (compute-loop nil)))) + (setf loop + `(block ,(if colonp 'outside-loop nil) + ,loop)) + (unless atsignp + (setf loop + `(let* ((orig-args (next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,loop))) + (when (zerop posn) + (setf loop + `(let ((inside-string (next-arg))) + ,loop))) + (values loop (subseq directives (1+ posn)))))))) + +(def-complex-format-directive #\} () + (error 'format-error + :complaint "No corresponding open brace.")) + +(def-complex-format-directive #\< (colonp atsignp params directives) + (let ((first-semi nil) + (close nil) + (remaining directives)) + (collect ((segments)) + (loop + (let ((close-or-semi (find-directive remaining #\> t))) + (unless close-or-semi + (error 'format-error + :complaint "No corresponding close bracket.")) + (let ((posn (position close-or-semi remaining))) + (segments (subseq remaining 0 posn)) + (setf remaining (subseq remaining (1+ posn)))) + (when (char= (format-directive-character close-or-semi) + #\>) + (setf close close-or-semi) + (return)) + (unless first-semi + (setf first-semi close-or-semi)))) + (values + (if (format-directive-colonp close) + (expand-format-logical-block (segments) colonp atsignp + first-semi close params) + (expand-format-justification (segments) colonp atsignp + first-semi params)) + remaining)))) + +(defun expand-format-justification + (segments colonp atsignp first-semi params) + (let ((newline-segment-p + (and first-semi + (format-directive-colonp first-semi)))) + (bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) params + `(let ((segments nil) + ,@(when newline-segment-p + '((newline-segment nil) + (extra-space 0) + (line-len 72)))) + (block nil + ,@(when newline-segment-p + `((setf newline-segment + (with-output-to-string (stream) + ,@(expand-directive-list (pop segments)))) + ,(bind-defaults ((extra 0) + (line-len '(or (lisp::line-length stream) + 72))) + (format-directive-params first-semi) + `(setf extra-space ,extra line-len ,line-len)))) + ,@(mapcar #'(lambda (segment) + `(push (with-output-to-string (stream) + ,@(expand-directive-list segment)) + segments)) + segments)) + (format-justification stream + ,@(if newline-segment-p + '(newline-segment extra-space line-len) + '(nil 0 0)) + segments ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))))) + +(defun format-justification (stream newline-prefix extra-space line-len strings + pad-left pad-right mincol colinc minpad padchar) + (when (and (not pad-left) (not pad-right) (null (cdr strings))) + (setf pad-left t)) + (let* ((num-gaps (+ (1- (length strings)) + (if pad-left 1 0) + (if pad-right 1 0))) + (chars (+ (* num-gaps minpad) + (loop + for string in strings + summing (length string)))) + (length (if (> chars mincol) + (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) + mincol)) + (padding (- length chars))) + (when (and newline-prefix + (> (+ (lisp::charpos stream) length extra-space) line-len)) + (write-string newline-prefix stream)) + (flet ((do-padding () + (let ((pad-len (truncate padding num-gaps))) + (decf padding pad-len) + (decf num-gaps) + (dotimes (i pad-len) (write-char padchar stream))))) + (when pad-left + (do-padding)) + (when strings + (write-string (car strings) stream) + (dolist (string (cdr strings)) + (do-padding) + (write-string string stream))) + (when pad-right + (do-padding))))) + +(def-complex-format-directive #\> () + (error 'format-error + :complaint "No corresponding open bracket.")) + +(def-format-directive #\^ (colonp atsignp params) + (when atsignp + (error 'format-error + :complaint "Cannot specify the at-sign modifier.")) + (when (and colonp (not *up-up-and-out-allowed*)) + (error 'format-error + :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct.")) + `(when ,(case (length params) + (0 (if colonp + '(null outside-args) + '(null args))) + (1 (bind-defaults ((count 0)) params + `(zerop ,count))) + (2 (bind-defaults ((arg1 0) (arg2 0)) params + `(= ,arg1 ,arg2))) + (t (bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params + `(<= ,arg1 ,arg2 ,arg3)))) + ,(if colonp + '(return-from outside-loop nil) + '(return)))) + +(def-format-directive #\/ (string start end colonp atsignp params) + (let ((slash (position #\/ string :start start :end (1- end) + :from-end t))) + (unless slash + (error 'format-error + :complaint "Malformed ~~/ directive.")) + (let* ((name (string-upcase (let ((foo string)) + ;; Hack alert: This is to keep the compiler + ;; quit about deleting code inside the subseq + ;; expansion. + (subseq foo (1+ slash) (1- end))))) + (first-colon (position #\: name)) + (last-colon (if first-colon (position #\: name :from-end t))) + (package-name (if last-colon + (subseq name (1+ last-colon)) + "USER")) + (package (find-package package-name))) + (unless package + (error 'format-error + :complaint "No package named ``~A''." + :arguments (list package-name))) + (let ((symbol (intern (if first-colon + (subseq name 0 first-colon) + name) + package))) + (collect ((param-names) (bindings)) + (dolist (param params) + (let ((param-name (gensym))) + (param-names param-name) + (bindings `(,param-name + ,(case param + (:arg '(next-arg)) + (:remaining '(length args)) + (t param)))))) + `(let ,(bindings) + (,symbol stream (next-arg) ,colonp ,atsignp + ,@(param-names))))))))