((complaint :reader format-error-complaint :initarg :complaint)
(args :reader format-error-args :initarg :args :initform nil)
(control-string :reader format-error-control-string
- :initarg :control-string
- :initform *default-format-error-control-string*)
+ :initarg :control-string
+ :initform *default-format-error-control-string*)
(offset :reader format-error-offset :initarg :offset
- :initform *default-format-error-offset*)
+ :initform *default-format-error-offset*)
(second-relative :reader format-error-second-relative
:initarg :second-relative :initform nil)
(print-banner :reader format-error-print-banner :initarg :print-banner
- :initform t))
+ :initform t))
(:report %print-format-error)
(:default-initargs :references nil))
(defun %print-format-error (condition stream)
(format stream
- "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]"
- (format-error-print-banner condition)
+ "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]"
+ (format-error-print-banner condition)
'format
- (format-error-complaint condition)
- (format-error-args condition)
- (format-error-control-string condition)
- (format-error-offset condition)
+ (format-error-complaint condition)
+ (format-error-args condition)
+ (format-error-control-string condition)
+ (format-error-offset condition)
(format-error-second-relative condition)))
\f
(def!struct format-directive
(def!method print-object ((x format-directive) stream)
(print-unreadable-object (x stream)
(write-string (format-directive-string x)
- stream
- :start (format-directive-start x)
- :end (format-directive-end x))))
+ stream
+ :start (format-directive-start x)
+ :end (format-directive-end x))))
\f
;;;; TOKENIZE-CONTROL-STRING
(defun tokenize-control-string (string)
(declare (simple-string string))
(let ((index 0)
- (end (length string))
- (result nil)
+ (end (length string))
+ (result nil)
;; FIXME: consider rewriting this 22.3.5.2-related processing
;; using specials to maintain state and doing the logic inside
;; the directive expanders themselves.
(justification-semicolon))
(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))
+ (when (> next-directive index)
+ (push (subseq string index next-directive) result))
+ (when (= next-directive end)
+ (return))
+ (let* ((directive (parse-directive string next-directive))
(char (format-directive-character directive)))
;; this processing is required by CLHS 22.3.5.2
(cond
(#\T (when (and (format-directive-colonp directive)
(not pprint))
(setf pprint directive))))))
- (push directive result)
- (setf index (format-directive-end directive)))))
+ (push directive result)
+ (setf index (format-directive-end directive)))))
(when (and pprint justification-semicolon)
(let ((pprint-offset (1- (format-directive-end pprint)))
(justification-offset
(defun parse-directive (string start)
(let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
- (end (length string)))
+ (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)))
- (check-ordering ()
- (when (or colonp atsignp)
- (error 'format-error
- :complaint "parameters found after #\\: or #\\@ modifier"
- :control-string string
- :offset posn
+ (if (= posn end)
+ (error 'format-error
+ :complaint "string ended before directive was found"
+ :control-string string
+ :offset start)
+ (schar string posn)))
+ (check-ordering ()
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint "parameters found after #\\: or #\\@ modifier"
+ :control-string string
+ :offset posn
:references (list '(:ansi-cl :section (22 3)))))))
(loop
- (let ((char (get-char)))
- (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
- (check-ordering)
- (multiple-value-bind (param new-posn)
- (parse-integer string :start posn :junk-allowed t)
- (push (cons posn param) params)
- (setf posn new-posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return)))))
- ((or (char= char #\v)
- (char= char #\V))
- (check-ordering)
- (push (cons posn :arg) params)
- (incf posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return))))
- ((char= char #\#)
- (check-ordering)
- (push (cons posn :remaining) params)
- (incf posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return))))
- ((char= char #\')
- (check-ordering)
- (incf posn)
- (push (cons posn (get-char)) params)
- (incf posn)
- (unless (char= (get-char) #\,)
- (decf posn)))
- ((char= char #\,)
- (check-ordering)
- (push (cons posn nil) params))
- ((char= char #\:)
- (if colonp
- (error 'format-error
- :complaint "too many colons supplied"
- :control-string string
- :offset posn
+ (let ((char (get-char)))
+ (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
+ (check-ordering)
+ (multiple-value-bind (param new-posn)
+ (parse-integer string :start posn :junk-allowed t)
+ (push (cons posn param) params)
+ (setf posn new-posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return)))))
+ ((or (char= char #\v)
+ (char= char #\V))
+ (check-ordering)
+ (push (cons posn :arg) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\#)
+ (check-ordering)
+ (push (cons posn :remaining) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\')
+ (check-ordering)
+ (incf posn)
+ (push (cons posn (get-char)) params)
+ (incf posn)
+ (unless (char= (get-char) #\,)
+ (decf posn)))
+ ((char= char #\,)
+ (check-ordering)
+ (push (cons posn nil) params))
+ ((char= char #\:)
+ (if colonp
+ (error 'format-error
+ :complaint "too many colons supplied"
+ :control-string string
+ :offset posn
:references (list '(:ansi-cl :section (22 3))))
- (setf colonp t)))
- ((char= char #\@)
- (if atsignp
- (error 'format-error
- :complaint "too many #\\@ characters supplied"
- :control-string string
- :offset posn
+ (setf colonp t)))
+ ((char= char #\@)
+ (if atsignp
+ (error 'format-error
+ :complaint "too many #\\@ characters supplied"
+ :control-string string
+ :offset posn
:references (list '(:ansi-cl :section (22 3))))
- (setf atsignp t)))
- (t
- (when (and (char= (schar string (1- posn)) #\,)
- (or (< posn 2)
- (char/= (schar string (- posn 2)) #\')))
- (check-ordering)
- (push (cons (1- posn) nil) params))
- (return))))
- (incf posn))
+ (setf atsignp t)))
+ (t
+ (when (and (char= (schar string (1- posn)) #\,)
+ (or (< posn 2)
+ (char/= (schar string (- posn 2)) #\')))
+ (check-ordering)
+ (push (cons (1- posn) 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-upcase char)
- :colonp colonp :atsignp atsignp
- :params (nreverse params))))))
+ (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-upcase char)
+ :colonp colonp :atsignp atsignp
+ :params (nreverse params))))))
\f
;;;; FORMATTER stuff
(block nil
(catch 'need-orig-args
(let* ((*simple-args* nil)
- (*only-simple-args* t)
- (guts (expand-control-string control-string))
- (args nil))
- (dolist (arg *simple-args*)
- (push `(,(car arg)
- (error
- 'format-error
- :complaint "required argument missing"
- :control-string ,control-string
- :offset ,(cdr arg)))
- args))
- (return `(lambda (stream &optional ,@args &rest args)
- ,guts
- args))))
+ (*only-simple-args* t)
+ (guts (expand-control-string control-string))
+ (args nil))
+ (dolist (arg *simple-args*)
+ (push `(,(car arg)
+ (error
+ 'format-error
+ :complaint "required argument missing"
+ :control-string ,control-string
+ :offset ,(cdr arg)))
+ args))
+ (return `(lambda (stream &optional ,@args &rest args)
+ ,guts
+ args))))
(let ((*orig-args-available* t)
- (*only-simple-args* nil))
+ (*only-simple-args* nil))
`(lambda (stream &rest orig-args)
- (let ((args orig-args))
- ,(expand-control-string control-string)
- args)))))
+ (let ((args orig-args))
+ ,(expand-control-string control-string)
+ args)))))
(defun expand-control-string (string)
(let* ((string (etypecase string
- (simple-string
- string)
- (string
- (coerce string 'simple-string))))
- (*default-format-error-control-string* string)
- (directives (tokenize-control-string string)))
+ (simple-string
+ string)
+ (string
+ (coerce string 'simple-string))))
+ (*default-format-error-control-string* string)
+ (directives (tokenize-control-string string)))
`(block nil
,@(expand-directive-list directives))))
(defun expand-directive-list (directives)
(let ((results nil)
- (remaining-directives directives))
+ (remaining-directives directives))
(loop
(unless remaining-directives
- (return))
+ (return))
(multiple-value-bind (form new-directives)
- (expand-directive (car remaining-directives)
- (cdr remaining-directives))
- (push form results)
- (setf remaining-directives 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)
(base-char
(aref *format-directive-expanders* (char-code char)))
(character nil))))
- (*default-format-error-offset*
- (1- (format-directive-end directive))))
+ (*default-format-error-offset*
+ (1- (format-directive-end directive))))
(declare (type (or null function) expander))
(if expander
- (funcall expander directive more-directives)
- (error 'format-error
- :complaint "unknown directive ~@[(character: ~A)~]"
- :args (list (char-name (format-directive-character directive)))))))
+ (funcall expander directive more-directives)
+ (error 'format-error
+ :complaint "unknown directive ~@[(character: ~A)~]"
+ :args (list (char-name (format-directive-character directive)))))))
(simple-string
(values `(write-string ,directive stream)
- more-directives))))
+ more-directives))))
(defmacro-mundanely expander-next-arg (string offset)
`(if args
(pop args)
(error 'format-error
- :complaint "no more arguments"
- :control-string ,string
- :offset ,offset)))
+ :complaint "no more arguments"
+ :control-string ,string
+ :offset ,offset)))
(defun expand-next-arg (&optional offset)
(if (or *orig-args-available* (not *only-simple-args*))
`(,*expander-next-arg-macro*
- ,*default-format-error-control-string*
- ,(or offset *default-format-error-offset*))
+ ,*default-format-error-control-string*
+ ,(or offset *default-format-error-offset*))
(let ((symbol (gensym "FORMAT-ARG-")))
- (push (cons symbol (or offset *default-format-error-offset*))
- *simple-args*)
- symbol)))
+ (push (cons symbol (or offset *default-format-error-offset*))
+ *simple-args*)
+ symbol)))
(defmacro expand-bind-defaults (specs params &body body)
(once-only ((params params))
(if specs
- (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-and-offset (pop ,params))
- (offset (car param-and-offset))
- (param (cdr param-and-offset)))
- (case param
- (:arg `(or ,(expand-next-arg offset)
- ,,default))
- (:remaining
- (setf *only-simple-args* nil)
- '(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 ~W"
- :args (list ,(length specs))
- :offset (caar ,params)))
- ,,@body)))
- `(progn
- (when ,params
- (error 'format-error
- :complaint "too many parameters, expected none"
- :offset (caar ,params)))
- ,@body))))
+ (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-and-offset (pop ,params))
+ (offset (car param-and-offset))
+ (param (cdr param-and-offset)))
+ (case param
+ (:arg `(or ,(expand-next-arg offset)
+ ,,default))
+ (:remaining
+ (setf *only-simple-args* nil)
+ '(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 ~W"
+ :args (list ,(length specs))
+ :offset (caar ,params)))
+ ,,@body)))
+ `(progn
+ (when ,params
+ (error 'format-error
+ :complaint "too many parameters, expected none"
+ :offset (caar ,params)))
+ ,@body))))
\f
;;;; format directive machinery
;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
(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))))
+ "~:@(~: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
- (,(symbolicate "FORMAT-DIRECTIVE-" var)
- ,directive)))
- (butlast lambda-list))
- ,@body))
- `((declare (ignore ,directive ,directives))
- ,@body)))
+ ,@(if lambda-list
+ `((let ,(mapcar (lambda (var)
+ `(,var
+ (,(symbolicate "FORMAT-DIRECTIVE-" var)
+ ,directive)))
+ (butlast lambda-list))
+ ,@body))
+ `((declare (ignore ,directive ,directives))
+ ,@body)))
(%set-format-directive-expander ,char #',defun-name))))
;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
(defmacro def-format-directive (char lambda-list &body body)
(let ((directives (gensym))
- (declarations nil)
- (body-without-decls body))
+ (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)))
+ (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))))
+ ,directives))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun %set-format-directive-interpreter (char fn)
(setf (aref *format-directive-interpreters*
- (char-code (char-upcase char)))
- fn)
+ (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)))))
+ (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)))))
) ; EVAL-WHEN
\f
(def-format-directive #\A (colonp atsignp params)
(if params
(expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
- (padchar #\space))
- params
- `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
- ,mincol ,colinc ,minpad ,padchar))
+ (padchar #\space))
+ params
+ `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
+ ,mincol ,colinc ,minpad ,padchar))
`(princ ,(if colonp
- `(or ,(expand-next-arg) "()")
- (expand-next-arg))
- stream)))
+ `(or ,(expand-next-arg) "()")
+ (expand-next-arg))
+ stream)))
(def-format-directive #\S (colonp atsignp params)
(cond (params
- (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
- (padchar #\space))
- params
- `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
- ,mincol ,colinc ,minpad ,padchar)))
- (colonp
- `(let ((arg ,(expand-next-arg)))
- (if arg
- (prin1 arg stream)
- (princ "()" stream))))
- (t
- `(prin1 ,(expand-next-arg) stream))))
+ (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
+ (padchar #\space))
+ params
+ `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
+ ,mincol ,colinc ,minpad ,padchar)))
+ (colonp
+ `(let ((arg ,(expand-next-arg)))
+ (if arg
+ (prin1 arg stream)
+ (princ "()" stream))))
+ (t
+ `(prin1 ,(expand-next-arg) stream))))
(def-format-directive #\C (colonp atsignp params)
(expand-bind-defaults () params
(if colonp
- `(format-print-named-character ,(expand-next-arg) stream)
- (if atsignp
- `(prin1 ,(expand-next-arg) stream)
- `(write-char ,(expand-next-arg) stream)))))
+ `(format-print-named-character ,(expand-next-arg) stream)
+ (if atsignp
+ `(prin1 ,(expand-next-arg) stream)
+ `(write-char ,(expand-next-arg) stream)))))
(def-format-directive #\W (colonp atsignp params)
(expand-bind-defaults () params
(if (or colonp atsignp)
- `(let (,@(when colonp
- '((*print-pretty* t)))
- ,@(when atsignp
- '((*print-level* nil)
- (*print-length* nil))))
- (output-object ,(expand-next-arg) stream))
- `(output-object ,(expand-next-arg) stream))))
+ `(let (,@(when colonp
+ '((*print-pretty* t)))
+ ,@(when atsignp
+ '((*print-level* nil)
+ (*print-length* nil))))
+ (output-object ,(expand-next-arg) stream))
+ `(output-object ,(expand-next-arg) stream))))
\f
;;;; format directives for integer output
(defun expand-format-integer (base colonp atsignp params)
(if (or colonp atsignp params)
(expand-bind-defaults
- ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
- params
- `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
- ,base ,mincol ,padchar ,commachar
- ,commainterval))
+ ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
+ params
+ `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
+ ,base ,mincol ,padchar ,commachar
+ ,commainterval))
`(write ,(expand-next-arg) :stream stream :base ,base :radix nil
- :escape nil)))
+ :escape nil)))
(def-format-directive #\D (colonp atsignp params)
(expand-format-integer 10 colonp atsignp params))
((base nil) (mincol 0) (padchar #\space) (commachar #\,)
(commainterval 3))
params
- (let ((n-arg (gensym)))
+ (let ((n-arg (gensym)))
`(let ((,n-arg ,(expand-next-arg)))
(if ,base
(format-print-integer stream ,n-arg ,colonp ,atsignp
- ,base ,mincol
- ,padchar ,commachar ,commainterval)
+ ,base ,mincol
+ ,padchar ,commachar ,commainterval)
,(if atsignp
(if colonp
`(format-print-old-roman stream ,n-arg)
`(format-print-roman stream ,n-arg))
(if colonp
`(format-print-ordinal stream ,n-arg)
- `(format-print-cardinal stream ,n-arg))))))))
+ `(format-print-cardinal stream ,n-arg))))))))
\f
;;;; format directive for pluralization
(def-format-directive #\P (colonp atsignp params end)
(expand-bind-defaults () params
(let ((arg (cond
- ((not colonp)
- (expand-next-arg))
- (*orig-args-available*
- `(if (eq orig-args args)
- (error 'format-error
- :complaint "no previous argument"
- :offset ,(1- end))
- (do ((arg-ptr orig-args (cdr arg-ptr)))
- ((eq (cdr arg-ptr) args)
- (car arg-ptr)))))
- (*only-simple-args*
- (unless *simple-args*
- (error 'format-error
- :complaint "no previous argument"))
- (caar *simple-args*))
- (t
- (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
- (throw 'need-orig-args nil)))))
+ ((not colonp)
+ (expand-next-arg))
+ (*orig-args-available*
+ `(if (eq orig-args args)
+ (error 'format-error
+ :complaint "no previous argument"
+ :offset ,(1- end))
+ (do ((arg-ptr orig-args (cdr arg-ptr)))
+ ((eq (cdr arg-ptr) args)
+ (car arg-ptr)))))
+ (*only-simple-args*
+ (unless *simple-args*
+ (error 'format-error
+ :complaint "no previous argument"))
+ (caar *simple-args*))
+ (t
+ (/show0 "THROWing NEED-ORIG-ARGS from tilde-P")
+ (throw 'need-orig-args nil)))))
(if atsignp
- `(write-string (if (eql ,arg 1) "y" "ies") stream)
- `(unless (eql ,arg 1) (write-char #\s stream))))))
+ `(write-string (if (eql ,arg 1) "y" "ies") stream)
+ `(unless (eql ,arg 1) (write-char #\s stream))))))
\f
;;;; format directives for floating point output
(def-format-directive #\F (colonp atsignp params)
(when colonp
(error 'format-error
- :complaint
- "The colon modifier cannot be used with this directive."))
+ :complaint
+ "The colon modifier cannot be used with this directive."))
(expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
`(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
(def-format-directive #\E (colonp atsignp params)
(when colonp
(error 'format-error
- :complaint
- "The colon modifier cannot be used with this directive."))
+ :complaint
+ "The colon modifier cannot be used with this directive."))
(expand-bind-defaults
((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
params
`(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
- ,atsignp)))
+ ,atsignp)))
(def-format-directive #\G (colonp atsignp params)
(when colonp
(error 'format-error
- :complaint
- "The colon modifier cannot be used with this directive."))
+ :complaint
+ "The colon modifier cannot be used with this directive."))
(expand-bind-defaults
((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
params
(def-format-directive #\$ (colonp atsignp params)
(expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
`(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
- ,atsignp)))
+ ,atsignp)))
\f
;;;; format directives for line/page breaks etc.
(def-format-directive #\% (colonp atsignp params)
(when (or colonp atsignp)
(error 'format-error
- :complaint
- "The colon and atsign modifiers cannot be used with this directive."
- ))
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
(if params
(expand-bind-defaults ((count 1)) params
- `(dotimes (i ,count)
- (terpri stream)))
+ `(dotimes (i ,count)
+ (terpri stream)))
'(terpri stream)))
(def-format-directive #\& (colonp atsignp params)
(when (or colonp atsignp)
(error 'format-error
- :complaint
- "The colon and atsign modifiers cannot be used with this directive."
- ))
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
(if params
(expand-bind-defaults ((count 1)) params
- `(progn
- (fresh-line stream)
- (dotimes (i (1- ,count))
- (terpri stream))))
+ `(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
- "The colon and atsign modifiers cannot be used with this directive."
- ))
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
(if params
(expand-bind-defaults ((count 1)) params
- `(dotimes (i ,count)
- (write-char (code-char form-feed-char-code) stream)))
+ `(dotimes (i ,count)
+ (write-char (code-char form-feed-char-code) stream)))
'(write-char (code-char form-feed-char-code) stream)))
(def-format-directive #\~ (colonp atsignp params)
(when (or colonp atsignp)
(error 'format-error
- :complaint
- "The colon and atsign modifiers cannot be used with this directive."
- ))
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
(if params
(expand-bind-defaults ((count 1)) params
- `(dotimes (i ,count)
- (write-char #\~ stream)))
+ `(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 "both colon and atsign modifiers used simultaneously"))
+ :complaint "both colon and atsign modifiers used simultaneously"))
(values (expand-bind-defaults () params
- (if atsignp
- '(write-char #\newline stream)
- nil))
- (if (and (not colonp)
- directives
- (simple-string-p (car directives)))
- (cons (string-left-trim *format-whitespace-chars*
- (car directives))
- (cdr directives))
- directives)))
+ (if atsignp
+ '(write-char #\newline stream)
+ nil))
+ (if (and (not colonp)
+ directives
+ (simple-string-p (car directives)))
+ (cons (string-left-trim *format-whitespace-chars*
+ (car directives))
+ (cdr directives))
+ directives)))
\f
;;;; format directives for tabs and simple pretty printing
(def-format-directive #\T (colonp atsignp params)
(if colonp
(expand-bind-defaults ((n 1) (m 1)) params
- `(pprint-tab ,(if atsignp :section-relative :section)
- ,n ,m stream))
+ `(pprint-tab ,(if atsignp :section-relative :section)
+ ,n ,m stream))
(if atsignp
- (expand-bind-defaults ((colrel 1) (colinc 1)) params
- `(format-relative-tab stream ,colrel ,colinc))
- (expand-bind-defaults ((colnum 1) (colinc 1)) params
- `(format-absolute-tab stream ,colnum ,colinc)))))
+ (expand-bind-defaults ((colrel 1) (colinc 1)) params
+ `(format-relative-tab stream ,colrel ,colinc))
+ (expand-bind-defaults ((colnum 1) (colinc 1)) params
+ `(format-absolute-tab stream ,colnum ,colinc)))))
(def-format-directive #\_ (colonp atsignp params)
(expand-bind-defaults () params
`(pprint-newline ,(if colonp
- (if atsignp
- :mandatory
- :fill)
- (if atsignp
- :miser
- :linear))
- stream)))
+ (if atsignp
+ :mandatory
+ :fill)
+ (if atsignp
+ :miser
+ :linear))
+ stream)))
(def-format-directive #\I (colonp atsignp params)
(when atsignp
(error 'format-error
- :complaint
- "cannot use the at-sign modifier with this directive"))
+ :complaint
+ "cannot use the at-sign modifier with this directive"))
(expand-bind-defaults ((n 0)) params
`(pprint-indent ,(if colonp :current :block) ,n stream)))
\f
(def-format-directive #\* (colonp atsignp params end)
(if atsignp
(if colonp
- (error 'format-error
- :complaint
- "both colon and atsign modifiers used simultaneously")
- (expand-bind-defaults ((posn 0)) params
- (unless *orig-args-available*
- (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
- (throw 'need-orig-args nil))
- `(if (<= 0 ,posn (length orig-args))
- (setf args (nthcdr ,posn orig-args))
- (error 'format-error
- :complaint "Index ~W out of bounds. Should have been ~
+ (error 'format-error
+ :complaint
+ "both colon and atsign modifiers used simultaneously")
+ (expand-bind-defaults ((posn 0)) params
+ (unless *orig-args-available*
+ (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*")
+ (throw 'need-orig-args nil))
+ `(if (<= 0 ,posn (length orig-args))
+ (setf args (nthcdr ,posn orig-args))
+ (error 'format-error
+ :complaint "Index ~W out of bounds. Should have been ~
between 0 and ~W."
- :args (list ,posn (length orig-args))
- :offset ,(1- end)))))
+ :args (list ,posn (length orig-args))
+ :offset ,(1- end)))))
(if colonp
- (expand-bind-defaults ((n 1)) params
- (unless *orig-args-available*
- (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
- (throw 'need-orig-args nil))
- `(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 (nthcdr new-posn orig-args))
- (error 'format-error
- :complaint
- "Index ~W is out of bounds; should have been ~
+ (expand-bind-defaults ((n 1)) params
+ (unless *orig-args-available*
+ (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*")
+ (throw 'need-orig-args nil))
+ `(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 (nthcdr new-posn orig-args))
+ (error 'format-error
+ :complaint
+ "Index ~W is out of bounds; should have been ~
between 0 and ~W."
- :args (list new-posn (length orig-args))
- :offset ,(1- end)))))))
- (if params
- (expand-bind-defaults ((n 1)) params
- (setf *only-simple-args* nil)
- `(dotimes (i ,n)
- ,(expand-next-arg)))
- (expand-next-arg)))))
+ :args (list new-posn (length orig-args))
+ :offset ,(1- end)))))))
+ (if params
+ (expand-bind-defaults ((n 1)) params
+ (setf *only-simple-args* nil)
+ `(dotimes (i ,n)
+ ,(expand-next-arg)))
+ (expand-next-arg)))))
\f
;;;; format directive for indirection
(def-format-directive #\? (colonp atsignp params string end)
(when colonp
(error 'format-error
- :complaint "cannot use the colon modifier with this directive"))
+ :complaint "cannot use the colon modifier with this directive"))
(expand-bind-defaults () params
`(handler-bind
- ((format-error
- (lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :args (list condition)
- :print-banner nil
- :control-string ,string
- :offset ,(1- end)))))
+ ((format-error
+ (lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :args (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
,(if atsignp
- (if *orig-args-available*
- `(setf args (%format stream ,(expand-next-arg) orig-args args))
- (throw 'need-orig-args nil))
- `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
+ (if *orig-args-available*
+ `(setf args (%format stream ,(expand-next-arg) orig-args args))
+ (throw 'need-orig-args nil))
+ `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
\f
;;;; format directives for capitalization
(let ((close (find-directive directives #\) nil)))
(unless close
(error 'format-error
- :complaint "no corresponding close parenthesis"))
+ :complaint "no corresponding close parenthesis"))
(let* ((posn (position close directives))
- (before (subseq directives 0 posn))
- (after (nthcdr (1+ posn) directives)))
+ (before (subseq directives 0 posn))
+ (after (nthcdr (1+ posn) directives)))
(values
(expand-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)))
+ `(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 parenthesis"))
+ :complaint "no corresponding open parenthesis"))
\f
;;;; format directives and support functions for conditionalization
(parse-conditional-directive directives)
(values
(if atsignp
- (if colonp
- (error 'format-error
- :complaint
- "both colon and atsign modifiers used simultaneously")
- (if (cdr sublists)
- (error 'format-error
- :complaint
- "Can only specify one section")
- (expand-bind-defaults () params
- (expand-maybe-conditional (car sublists)))))
- (if colonp
- (if (= (length sublists) 2)
- (expand-bind-defaults () params
- (expand-true-false-conditional (car sublists)
- (cadr sublists)))
- (error 'format-error
- :complaint
- "must specify exactly two sections"))
- (expand-bind-defaults ((index nil)) params
- (setf *only-simple-args* nil)
- (let ((clauses nil)
+ (if colonp
+ (error 'format-error
+ :complaint
+ "both colon and atsign modifiers used simultaneously")
+ (if (cdr sublists)
+ (error 'format-error
+ :complaint
+ "Can only specify one section")
+ (expand-bind-defaults () params
+ (expand-maybe-conditional (car sublists)))))
+ (if colonp
+ (if (= (length sublists) 2)
+ (expand-bind-defaults () params
+ (expand-true-false-conditional (car sublists)
+ (cadr sublists)))
+ (error 'format-error
+ :complaint
+ "must specify exactly two sections"))
+ (expand-bind-defaults ((index nil)) params
+ (setf *only-simple-args* nil)
+ (let ((clauses nil)
(case `(or ,index ,(expand-next-arg))))
- (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 ,case ,@clauses)))))
+ (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 ,case ,@clauses)))))
remaining)))
(defun parse-conditional-directive (directives)
(let ((sublists nil)
- (last-semi-with-colon-p nil)
- (remaining directives))
+ (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 (nthcdr (1+ posn) remaining))
- (when (char= (format-directive-character close-or-semi) #\])
- (return))
- (setf last-semi-with-colon-p
- (format-directive-colonp close-or-semi)))))
+ (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 (nthcdr (1+ posn) remaining))
+ (when (char= (format-directive-character close-or-semi) #\])
+ (return))
+ (setf last-semi-with-colon-p
+ (format-directive-colonp close-or-semi)))))
(values sublists last-semi-with-colon-p remaining)))
(defun expand-maybe-conditional (sublist)
(flet ((hairy ()
- `(let ((prev-args args)
- (arg ,(expand-next-arg)))
- (when arg
- (setf args prev-args)
- ,@(expand-directive-list sublist)))))
+ `(let ((prev-args args)
+ (arg ,(expand-next-arg)))
+ (when arg
+ (setf args prev-args)
+ ,@(expand-directive-list sublist)))))
(if *only-simple-args*
- (multiple-value-bind (guts new-args)
- (let ((*simple-args* *simple-args*))
- (values (expand-directive-list sublist)
- *simple-args*))
- (cond ((and new-args (eq *simple-args* (cdr new-args)))
- (setf *simple-args* new-args)
- `(when ,(caar new-args)
- ,@guts))
- (t
- (setf *only-simple-args* nil)
- (hairy))))
- (hairy))))
+ (multiple-value-bind (guts new-args)
+ (let ((*simple-args* *simple-args*))
+ (values (expand-directive-list sublist)
+ *simple-args*))
+ (cond ((and new-args (eq *simple-args* (cdr new-args)))
+ (setf *simple-args* new-args)
+ `(when ,(caar new-args)
+ ,@guts))
+ (t
+ (setf *only-simple-args* nil)
+ (hairy))))
+ (hairy))))
(defun expand-true-false-conditional (true false)
(let ((arg (expand-next-arg)))
(flet ((hairy ()
- `(if ,arg
- (progn
- ,@(expand-directive-list true))
- (progn
- ,@(expand-directive-list false)))))
+ `(if ,arg
+ (progn
+ ,@(expand-directive-list true))
+ (progn
+ ,@(expand-directive-list false)))))
(if *only-simple-args*
- (multiple-value-bind (true-guts true-args true-simple)
- (let ((*simple-args* *simple-args*)
- (*only-simple-args* t))
- (values (expand-directive-list true)
- *simple-args*
- *only-simple-args*))
- (multiple-value-bind (false-guts false-args false-simple)
- (let ((*simple-args* *simple-args*)
- (*only-simple-args* t))
- (values (expand-directive-list false)
- *simple-args*
- *only-simple-args*))
- (if (= (length true-args) (length false-args))
- `(if ,arg
- (progn
- ,@true-guts)
- ,(do ((false false-args (cdr false))
- (true true-args (cdr true))
- (bindings nil (cons `(,(caar false) ,(caar true))
- bindings)))
- ((eq true *simple-args*)
- (setf *simple-args* true-args)
- (setf *only-simple-args*
- (and true-simple false-simple))
- (if bindings
- `(let ,bindings
- ,@false-guts)
- `(progn
- ,@false-guts)))))
- (progn
- (setf *only-simple-args* nil)
- (hairy)))))
- (hairy)))))
+ (multiple-value-bind (true-guts true-args true-simple)
+ (let ((*simple-args* *simple-args*)
+ (*only-simple-args* t))
+ (values (expand-directive-list true)
+ *simple-args*
+ *only-simple-args*))
+ (multiple-value-bind (false-guts false-args false-simple)
+ (let ((*simple-args* *simple-args*)
+ (*only-simple-args* t))
+ (values (expand-directive-list false)
+ *simple-args*
+ *only-simple-args*))
+ (if (= (length true-args) (length false-args))
+ `(if ,arg
+ (progn
+ ,@true-guts)
+ ,(do ((false false-args (cdr false))
+ (true true-args (cdr true))
+ (bindings nil (cons `(,(caar false) ,(caar true))
+ bindings)))
+ ((eq true *simple-args*)
+ (setf *simple-args* true-args)
+ (setf *only-simple-args*
+ (and true-simple false-simple))
+ (if bindings
+ `(let ,bindings
+ ,@false-guts)
+ `(progn
+ ,@false-guts)))))
+ (progn
+ (setf *only-simple-args* nil)
+ (hairy)))))
+ (hairy)))))
(def-complex-format-directive #\; ()
(error 'format-error
- :complaint
- "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
+ :complaint
+ "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
(def-complex-format-directive #\] ()
(error 'format-error
- :complaint
- "no corresponding open bracket"))
+ :complaint
+ "no corresponding open bracket"))
\f
;;;; format directive for up-and-out
(def-format-directive #\^ (colonp atsignp params)
(when atsignp
(error 'format-error
- :complaint "cannot use the at-sign modifier with this directive"))
+ :complaint "cannot use the at-sign modifier with this directive"))
(when (and colonp (not *up-up-and-out-allowed*))
(error 'format-error
- :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
+ :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
`(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
`(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
(,arg2 (eql ,arg1 ,arg2))
(setf *only-simple-args* nil)
'(null args))))))
,(if colonp
- '(return-from outside-loop nil)
- '(return))))
+ '(return-from outside-loop nil)
+ '(return))))
\f
;;;; format directives for iteration
(let ((close (find-directive directives #\} nil)))
(unless close
(error 'format-error
- :complaint "no corresponding close brace"))
+ :complaint "no corresponding close brace"))
(let* ((closed-with-colon (format-directive-colonp close))
- (posn (position close directives)))
+ (posn (position close directives)))
(labels
- ((compute-insides ()
- (if (zerop posn)
- (if *orig-args-available*
- `((handler-bind
- ((format-error
- (lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :args (list condition)
- :print-banner nil
- :control-string ,string
- :offset ,(1- end)))))
- (setf args
- (%format stream inside-string orig-args args))))
- (throw 'need-orig-args nil))
- (let ((*up-up-and-out-allowed* colonp))
- (expand-directive-list (subseq directives 0 posn)))))
- (compute-loop (count)
- (when atsignp
- (setf *only-simple-args* nil))
- `(loop
- ,@(unless closed-with-colon
- '((when (null args)
- (return))))
- ,@(when count
- `((when (and ,count (minusp (decf ,count)))
- (return))))
- ,@(if colonp
- (let ((*expander-next-arg-macro* 'expander-next-arg)
- (*only-simple-args* nil)
- (*orig-args-available* t))
- `((let* ((orig-args ,(expand-next-arg))
- (outside-args args)
- (args orig-args))
- (declare (ignorable orig-args outside-args args))
- (block nil
- ,@(compute-insides)))))
- (compute-insides))
- ,@(when closed-with-colon
- '((when (null args)
- (return))))))
- (compute-block (count)
- (if colonp
- `(block outside-loop
- ,(compute-loop count))
- (compute-loop count)))
- (compute-bindings (count)
- (if atsignp
+ ((compute-insides ()
+ (if (zerop posn)
+ (if *orig-args-available*
+ `((handler-bind
+ ((format-error
+ (lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :args (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
+ (setf args
+ (%format stream inside-string orig-args args))))
+ (throw 'need-orig-args nil))
+ (let ((*up-up-and-out-allowed* colonp))
+ (expand-directive-list (subseq directives 0 posn)))))
+ (compute-loop (count)
+ (when atsignp
+ (setf *only-simple-args* nil))
+ `(loop
+ ,@(unless closed-with-colon
+ '((when (null args)
+ (return))))
+ ,@(when count
+ `((when (and ,count (minusp (decf ,count)))
+ (return))))
+ ,@(if colonp
+ (let ((*expander-next-arg-macro* 'expander-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available* t))
+ `((let* ((orig-args ,(expand-next-arg))
+ (outside-args args)
+ (args orig-args))
+ (declare (ignorable orig-args outside-args args))
+ (block nil
+ ,@(compute-insides)))))
+ (compute-insides))
+ ,@(when closed-with-colon
+ '((when (null args)
+ (return))))))
+ (compute-block (count)
+ (if colonp
+ `(block outside-loop
+ ,(compute-loop count))
+ (compute-loop count)))
+ (compute-bindings (count)
+ (if atsignp
(compute-block count)
`(let* ((orig-args ,(expand-next-arg))
(args orig-args))
(*only-simple-args* nil)
(*orig-args-available* t))
(compute-block count))))))
- (values (if params
+ (values (if params
(expand-bind-defaults ((count nil)) params
(if (zerop posn)
`(let ((inside-string ,(expand-next-arg)))
`(let ((inside-string ,(expand-next-arg)))
,(compute-bindings nil))
(compute-bindings nil)))
- (nthcdr (1+ posn) directives))))))
+ (nthcdr (1+ posn) directives))))))
(def-complex-format-directive #\} ()
(error 'format-error
- :complaint "no corresponding open brace"))
+ :complaint "no corresponding open brace"))
\f
;;;; format directives and support functions for justification
(defparameter *illegal-inside-justification*
(mapcar (lambda (x) (parse-directive x 0))
- '("~W" "~:W" "~@W" "~:@W"
- "~_" "~:_" "~@_" "~:@_"
- "~:>" "~:@>"
- "~I" "~:I" "~@I" "~:@I"
- "~:T" "~:@T")))
+ '("~W" "~:W" "~@W" "~:@W"
+ "~_" "~:_" "~@_" "~:@_"
+ "~:>" "~:@>"
+ "~I" "~:I" "~@I" "~:@I"
+ "~:T" "~:@T")))
(defun illegal-inside-justification-p (directive)
(member directive *illegal-inside-justification*
- :test (lambda (x y)
- (and (format-directive-p x)
- (format-directive-p y)
- (eql (format-directive-character x) (format-directive-character y))
- (eql (format-directive-colonp x) (format-directive-colonp y))
- (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
+ :test (lambda (x y)
+ (and (format-directive-p x)
+ (format-directive-p y)
+ (eql (format-directive-character x) (format-directive-character y))
+ (eql (format-directive-colonp x) (format-directive-colonp y))
+ (eql (format-directive-atsignp x) (format-directive-atsignp y))))))
(def-complex-format-directive #\< (colonp atsignp params string end directives)
(multiple-value-bind (segments first-semi close remaining)
(parse-format-justification directives)
(values
(if (format-directive-colonp close)
- (multiple-value-bind (prefix per-line-p insides suffix)
- (parse-format-logical-block segments colonp first-semi
- close params string end)
- (expand-format-logical-block prefix per-line-p insides
- suffix atsignp))
- (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
- (when (> count 0)
- ;; ANSI specifies that "an error is signalled" in this
- ;; situation.
- (error 'format-error
- :complaint "~D illegal directive~:P found inside justification block"
- :args (list count)
+ (multiple-value-bind (prefix per-line-p insides suffix)
+ (parse-format-logical-block segments colonp first-semi
+ close params string end)
+ (expand-format-logical-block prefix per-line-p insides
+ suffix atsignp))
+ (let ((count (reduce #'+ (mapcar (lambda (x) (count-if #'illegal-inside-justification-p x)) segments))))
+ (when (> count 0)
+ ;; ANSI specifies that "an error is signalled" in this
+ ;; situation.
+ (error 'format-error
+ :complaint "~D illegal directive~:P found inside justification block"
+ :args (list count)
:references (list '(:ansi-cl :section (22 3 5 2)))))
- (expand-format-justification segments colonp atsignp
+ (expand-format-justification segments colonp atsignp
first-semi params)))
remaining)))
(def-complex-format-directive #\> ()
(error 'format-error
- :complaint "no corresponding open bracket"))
+ :complaint "no corresponding open bracket"))
(defun parse-format-logical-block
(segments colonp first-semi close params string end)
(when params
(error 'format-error
- :complaint "No parameters can be supplied with ~~<...~~:>."
- :offset (caar params)))
+ :complaint "No parameters can be supplied with ~~<...~~:>."
+ :offset (caar params)))
(multiple-value-bind (prefix insides suffix)
(multiple-value-bind (prefix-default suffix-default)
- (if colonp (values "(" ")") (values "" ""))
- (flet ((extract-string (list prefix-p)
- (let ((directive (find-if #'format-directive-p list)))
- (if directive
- (error 'format-error
- :complaint
+ (if colonp (values "(" ")") (values "" ""))
+ (flet ((extract-string (list prefix-p)
+ (let ((directive (find-if #'format-directive-p list)))
+ (if directive
+ (error 'format-error
+ :complaint
"cannot include format directives inside the ~
~:[suffix~;prefix~] segment of ~~<...~~:>"
- :args (list prefix-p)
- :offset (1- (format-directive-end directive))
+ :args (list prefix-p)
+ :offset (1- (format-directive-end directive))
:references
(list '(:ansi-cl :section (22 3 5 2))))
- (apply #'concatenate 'string list)))))
- (case (length segments)
- (0 (values prefix-default nil suffix-default))
- (1 (values prefix-default (car segments) suffix-default))
- (2 (values (extract-string (car segments) t)
- (cadr segments) suffix-default))
- (3 (values (extract-string (car segments) t)
- (cadr segments)
- (extract-string (caddr segments) nil)))
- (t
- (error 'format-error
- :complaint "too many segments for ~~<...~~:>")))))
+ (apply #'concatenate 'string list)))))
+ (case (length segments)
+ (0 (values prefix-default nil suffix-default))
+ (1 (values prefix-default (car segments) suffix-default))
+ (2 (values (extract-string (car segments) t)
+ (cadr segments) suffix-default))
+ (3 (values (extract-string (car segments) t)
+ (cadr segments)
+ (extract-string (caddr segments) nil)))
+ (t
+ (error 'format-error
+ :complaint "too many segments for ~~<...~~:>")))))
(when (format-directive-atsignp close)
(setf insides
- (add-fill-style-newlines insides
- string
- (if first-semi
- (format-directive-end first-semi)
- end))))
+ (add-fill-style-newlines insides
+ string
+ (if first-semi
+ (format-directive-end first-semi)
+ end))))
(values prefix
- (and first-semi (format-directive-atsignp first-semi))
- insides
- suffix)))
+ (and first-semi (format-directive-atsignp first-semi))
+ insides
+ suffix)))
(defun add-fill-style-newlines (list string offset &optional last-directive)
(cond
(list
(let ((directive (car list)))
(cond
- ((simple-string-p directive)
- (let* ((non-space (position #\Space directive :test #'char/=))
- (newlinep (and last-directive
- (char=
- (format-directive-character last-directive)
- #\Newline))))
- (cond
- ((and newlinep non-space)
- (nconc
- (list (subseq directive 0 non-space))
- (add-fill-style-newlines-aux
- (subseq directive non-space) string (+ offset non-space))
- (add-fill-style-newlines
- (cdr list) string (+ offset (length directive)))))
- (newlinep
- (cons directive
- (add-fill-style-newlines
- (cdr list) string (+ offset (length directive)))))
- (t
- (nconc (add-fill-style-newlines-aux directive string offset)
- (add-fill-style-newlines
- (cdr list) string (+ offset (length directive))))))))
- (t
- (cons directive
- (add-fill-style-newlines
- (cdr list) string
- (format-directive-end directive) directive))))))
+ ((simple-string-p directive)
+ (let* ((non-space (position #\Space directive :test #'char/=))
+ (newlinep (and last-directive
+ (char=
+ (format-directive-character last-directive)
+ #\Newline))))
+ (cond
+ ((and newlinep non-space)
+ (nconc
+ (list (subseq directive 0 non-space))
+ (add-fill-style-newlines-aux
+ (subseq directive non-space) string (+ offset non-space))
+ (add-fill-style-newlines
+ (cdr list) string (+ offset (length directive)))))
+ (newlinep
+ (cons directive
+ (add-fill-style-newlines
+ (cdr list) string (+ offset (length directive)))))
+ (t
+ (nconc (add-fill-style-newlines-aux directive string offset)
+ (add-fill-style-newlines
+ (cdr list) string (+ offset (length directive))))))))
+ (t
+ (cons directive
+ (add-fill-style-newlines
+ (cdr list) string
+ (format-directive-end directive) directive))))))
(t nil)))
(defun add-fill-style-newlines-aux (literal string offset)
(let ((end (length literal))
- (posn 0))
+ (posn 0))
(collect ((results))
(loop
- (let ((blank (position #\space literal :start posn)))
- (when (null blank)
- (results (subseq literal posn))
- (return))
- (let ((non-blank (or (position #\space literal :start blank
- :test #'char/=)
- end)))
- (results (subseq literal posn non-blank))
- (results (make-format-directive
- :string string :character #\_
- :start (+ offset non-blank) :end (+ offset non-blank)
- :colonp t :atsignp nil :params nil))
- (setf posn non-blank))
- (when (= posn end)
- (return))))
+ (let ((blank (position #\space literal :start posn)))
+ (when (null blank)
+ (results (subseq literal posn))
+ (return))
+ (let ((non-blank (or (position #\space literal :start blank
+ :test #'char/=)
+ end)))
+ (results (subseq literal posn non-blank))
+ (results (make-format-directive
+ :string string :character #\_
+ :start (+ offset non-blank) :end (+ offset non-blank)
+ :colonp t :atsignp nil :params nil))
+ (setf posn non-blank))
+ (when (= posn end)
+ (return))))
(results))))
(defun parse-format-justification (directives)
(let ((first-semi nil)
- (close nil)
- (remaining directives))
+ (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 (nthcdr (1+ posn) remaining)))
- (when (char= (format-directive-character close-or-semi)
- #\>)
- (setf close close-or-semi)
- (return))
- (unless first-semi
- (setf first-semi close-or-semi))))
+ (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 (nthcdr (1+ posn) remaining)))
+ (when (char= (format-directive-character close-or-semi)
+ #\>)
+ (setf close close-or-semi)
+ (return))
+ (unless first-semi
+ (setf first-semi close-or-semi))))
(values (segments) first-semi close remaining))))
(sb!xc:defmacro expander-pprint-next-arg (string offset)
`(progn
(when (null args)
(error 'format-error
- :complaint "no more arguments"
- :control-string ,string
- :offset ,offset))
+ :complaint "no more arguments"
+ :control-string ,string
+ :offset ,offset))
(pprint-pop)
(pop args)))
(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
`(let ((arg ,(if atsignp 'args (expand-next-arg))))
,@(when atsignp
- (setf *only-simple-args* nil)
- '((setf args nil)))
+ (setf *only-simple-args* nil)
+ '((setf args nil)))
(pprint-logical-block
- (stream arg
- ,(if per-line-p :per-line-prefix :prefix) ,prefix
- :suffix ,suffix)
+ (stream arg
+ ,(if per-line-p :per-line-prefix :prefix) ,prefix
+ :suffix ,suffix)
(let ((args arg)
- ,@(unless atsignp
- `((orig-args arg))))
- (declare (ignorable args ,@(unless atsignp '(orig-args))))
- (block nil
- ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
- (*only-simple-args* nil)
- (*orig-args-available*
- (if atsignp *orig-args-available* t)))
- (expand-directive-list insides)))))))
+ ,@(unless atsignp
+ `((orig-args arg))))
+ (declare (ignorable args ,@(unless atsignp '(orig-args))))
+ (block nil
+ ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available*
+ (if atsignp *orig-args-available* t)))
+ (expand-directive-list insides)))))))
(defun expand-format-justification (segments colonp atsignp first-semi params)
(let ((newline-segment-p
- (and first-semi
- (format-directive-colonp first-semi))))
+ (and first-semi
+ (format-directive-colonp first-semi))))
(expand-bind-defaults
- ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
- params
+ ((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))))
- ,(expand-bind-defaults
- ((extra 0)
- (line-len '(or (sb!impl::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)))))
+ ,@(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))))
+ ,(expand-bind-defaults
+ ((extra 0)
+ (line-len '(or (sb!impl::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)))))
\f
;;;; format directive and support function for user-defined method
(let ((symbol (extract-user-fun-name string start end)))
(collect ((param-names) (bindings))
(dolist (param-and-offset params)
- (let ((param (cdr param-and-offset)))
- (let ((param-name (gensym)))
- (param-names param-name)
- (bindings `(,param-name
- ,(case param
- (:arg (expand-next-arg))
- (:remaining '(length args))
- (t param)))))))
+ (let ((param (cdr param-and-offset)))
+ (let ((param-name (gensym)))
+ (param-names param-name)
+ (bindings `(,param-name
+ ,(case param
+ (:arg (expand-next-arg))
+ (:remaining '(length args))
+ (t param)))))))
`(let ,(bindings)
- (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
- ,@(param-names))))))
+ (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
+ ,@(param-names))))))
(defun extract-user-fun-name (string start end)
(let ((slash (position #\/ string :start start :end (1- end)
- :from-end t)))
+ :from-end t)))
(unless slash
(error 'format-error
- :complaint "malformed ~~/ directive"))
+ :complaint "malformed ~~/ directive"))
(let* ((name (string-upcase (let ((foo string))
- ;; Hack alert: This is to keep the compiler
- ;; quiet about deleting code inside the
- ;; subseq expansion.
- (subseq foo (1+ slash) (1- end)))))
- (first-colon (position #\: name))
- (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
- (package-name (if first-colon
- (subseq name 0 first-colon)
- "COMMON-LISP-USER"))
- (package (find-package package-name)))
+ ;; Hack alert: This is to keep the compiler
+ ;; quiet about deleting code inside the
+ ;; subseq expansion.
+ (subseq foo (1+ slash) (1- end)))))
+ (first-colon (position #\: name))
+ (second-colon (if first-colon (position #\: name :start (1+ first-colon))))
+ (package-name (if first-colon
+ (subseq name 0 first-colon)
+ "COMMON-LISP-USER"))
+ (package (find-package package-name)))
(unless package
- ;; FIXME: should be PACKAGE-ERROR? Could we just use
- ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
- (error 'format-error
- :complaint "no package named ~S"
- :args (list package-name)))
+ ;; FIXME: should be PACKAGE-ERROR? Could we just use
+ ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
+ (error 'format-error
+ :complaint "no package named ~S"
+ :args (list package-name)))
(intern (cond
- ((and second-colon (= second-colon (1+ first-colon)))
- (subseq name (1+ second-colon)))
- (first-colon
- (subseq name (1+ first-colon)))
- (t name))
- package))))
+ ((and second-colon (= second-colon (1+ first-colon)))
+ (subseq name (1+ second-colon)))
+ (first-colon
+ (subseq name (1+ first-colon)))
+ (t name))
+ package))))
;;; compile-time checking for argument mismatch. This code is
;;; inspired by that of Gerd Moellmann, and comes decorated with
(declare (type simple-string string))
(let ((*default-format-error-control-string* string))
(macrolet ((incf-both (&optional (increment 1))
- `(progn
- (incf min ,increment)
- (incf max ,increment)))
- (walk-complex-directive (function)
- `(multiple-value-bind (min-inc max-inc remaining)
- (,function directive directives args)
- (incf min min-inc)
- (incf max max-inc)
- (setq directives remaining))))
+ `(progn
+ (incf min ,increment)
+ (incf max ,increment)))
+ (walk-complex-directive (function)
+ `(multiple-value-bind (min-inc max-inc remaining)
+ (,function directive directives args)
+ (incf min min-inc)
+ (incf max max-inc)
+ (setq directives remaining))))
;; FIXME: these functions take a list of arguments as well as
;; the directive stream. This is to enable possibly some
;; limited type checking on FORMAT's arguments, as well as
;; directive, and some (annotated below) require arguments of
;; particular types.
(labels
- ((walk-justification (justification directives args)
- (declare (ignore args))
- (let ((*default-format-error-offset*
- (1- (format-directive-end justification))))
- (multiple-value-bind (segments first-semi close remaining)
- (parse-format-justification directives)
- (declare (ignore segments first-semi))
- (cond
- ((not (format-directive-colonp close))
- (values 0 0 directives))
- ((format-directive-atsignp justification)
- (values 0 sb!xc:call-arguments-limit directives))
- ;; FIXME: here we could assert that the
- ;; corresponding argument was a list.
- (t (values 1 1 remaining))))))
- (walk-conditional (conditional directives args)
- (let ((*default-format-error-offset*
- (1- (format-directive-end conditional))))
- (multiple-value-bind (sublists last-semi-with-colon-p remaining)
- (parse-conditional-directive directives)
- (declare (ignore last-semi-with-colon-p))
- (let ((sub-max
- (loop for s in sublists
- maximize (nth-value
- 1 (walk-directive-list s args)))))
- (cond
- ((format-directive-atsignp conditional)
- (values 1 (max 1 sub-max) remaining))
- ((loop for p in (format-directive-params conditional)
- thereis (or (integerp (cdr p))
- (memq (cdr p) '(:remaining :arg))))
- (values 0 sub-max remaining))
- ;; FIXME: if not COLONP, then the next argument
- ;; must be a number.
- (t (values 1 (1+ sub-max) remaining)))))))
- (walk-iteration (iteration directives args)
- (declare (ignore args))
- (let ((*default-format-error-offset*
- (1- (format-directive-end iteration))))
- (let* ((close (find-directive directives #\} nil))
- (posn (or (position close directives)
+ ((walk-justification (justification directives args)
+ (declare (ignore args))
+ (let ((*default-format-error-offset*
+ (1- (format-directive-end justification))))
+ (multiple-value-bind (segments first-semi close remaining)
+ (parse-format-justification directives)
+ (declare (ignore segments first-semi))
+ (cond
+ ((not (format-directive-colonp close))
+ (values 0 0 directives))
+ ((format-directive-atsignp justification)
+ (values 0 sb!xc:call-arguments-limit directives))
+ ;; FIXME: here we could assert that the
+ ;; corresponding argument was a list.
+ (t (values 1 1 remaining))))))
+ (walk-conditional (conditional directives args)
+ (let ((*default-format-error-offset*
+ (1- (format-directive-end conditional))))
+ (multiple-value-bind (sublists last-semi-with-colon-p remaining)
+ (parse-conditional-directive directives)
+ (declare (ignore last-semi-with-colon-p))
+ (let ((sub-max
+ (loop for s in sublists
+ maximize (nth-value
+ 1 (walk-directive-list s args)))))
+ (cond
+ ((format-directive-atsignp conditional)
+ (values 1 (max 1 sub-max) remaining))
+ ((loop for p in (format-directive-params conditional)
+ thereis (or (integerp (cdr p))
+ (memq (cdr p) '(:remaining :arg))))
+ (values 0 sub-max remaining))
+ ;; FIXME: if not COLONP, then the next argument
+ ;; must be a number.
+ (t (values 1 (1+ sub-max) remaining)))))))
+ (walk-iteration (iteration directives args)
+ (declare (ignore args))
+ (let ((*default-format-error-offset*
+ (1- (format-directive-end iteration))))
+ (let* ((close (find-directive directives #\} nil))
+ (posn (or (position close directives)
(error 'format-error
:complaint "no corresponding close brace")))
- (remaining (nthcdr (1+ posn) directives)))
- ;; FIXME: if POSN is zero, the next argument must be
- ;; a format control (either a function or a string).
- (if (format-directive-atsignp iteration)
- (values (if (zerop posn) 1 0)
- sb!xc:call-arguments-limit
- remaining)
- ;; FIXME: the argument corresponding to this
- ;; directive must be a list.
- (let ((nreq (if (zerop posn) 2 1)))
- (values nreq nreq remaining))))))
- (walk-directive-list (directives args)
- (let ((min 0) (max 0))
- (loop
- (let ((directive (pop directives)))
- (when (null directive)
- (return (values min (min max sb!xc:call-arguments-limit))))
- (when (format-directive-p directive)
- (incf-both (count :arg (format-directive-params directive)
- :key #'cdr))
- (let ((c (format-directive-character directive)))
- (cond
- ((find c "ABCDEFGORSWX$/")
- (incf-both))
- ((char= c #\P)
- (unless (format-directive-colonp directive)
- (incf-both)))
- ((or (find c "IT%&|_();>~") (char= c #\Newline)))
+ (remaining (nthcdr (1+ posn) directives)))
+ ;; FIXME: if POSN is zero, the next argument must be
+ ;; a format control (either a function or a string).
+ (if (format-directive-atsignp iteration)
+ (values (if (zerop posn) 1 0)
+ sb!xc:call-arguments-limit
+ remaining)
+ ;; FIXME: the argument corresponding to this
+ ;; directive must be a list.
+ (let ((nreq (if (zerop posn) 2 1)))
+ (values nreq nreq remaining))))))
+ (walk-directive-list (directives args)
+ (let ((min 0) (max 0))
+ (loop
+ (let ((directive (pop directives)))
+ (when (null directive)
+ (return (values min (min max sb!xc:call-arguments-limit))))
+ (when (format-directive-p directive)
+ (incf-both (count :arg (format-directive-params directive)
+ :key #'cdr))
+ (let ((c (format-directive-character directive)))
+ (cond
+ ((find c "ABCDEFGORSWX$/")
+ (incf-both))
+ ((char= c #\P)
+ (unless (format-directive-colonp directive)
+ (incf-both)))
+ ((or (find c "IT%&|_();>~") (char= c #\Newline)))
;; FIXME: check correspondence of ~( and ~)
- ((char= c #\<)
- (walk-complex-directive walk-justification))
- ((char= c #\[)
- (walk-complex-directive walk-conditional))
- ((char= c #\{)
- (walk-complex-directive walk-iteration))
- ((char= c #\?)
- ;; FIXME: the argument corresponding to this
- ;; directive must be a format control.
- (cond
- ((format-directive-atsignp directive)
- (incf min)
- (setq max sb!xc:call-arguments-limit))
- (t (incf-both 2))))
- (t (throw 'give-up-format-string-walk nil))))))))))
- (catch 'give-up-format-string-walk
- (let ((directives (tokenize-control-string string)))
- (walk-directive-list directives args)))))))
+ ((char= c #\<)
+ (walk-complex-directive walk-justification))
+ ((char= c #\[)
+ (walk-complex-directive walk-conditional))
+ ((char= c #\{)
+ (walk-complex-directive walk-iteration))
+ ((char= c #\?)
+ ;; FIXME: the argument corresponding to this
+ ;; directive must be a format control.
+ (cond
+ ((format-directive-atsignp directive)
+ (incf min)
+ (setq max sb!xc:call-arguments-limit))
+ (t (incf-both 2))))
+ (t (throw 'give-up-format-string-walk nil))))))))))
+ (catch 'give-up-format-string-walk
+ (let ((directives (tokenize-control-string string)))
+ (walk-directive-list directives args)))))))
projects / sbcl.git / blobdiff