;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!FORMAT") (define-condition format-error (error reference-condition) ((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*) (offset :reader format-error-offset :initarg :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)) (: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) 'format (format-error-complaint condition) (format-error-args condition) (format-error-control-string condition) (format-error-offset condition) (format-error-second-relative condition))) (def!struct format-directive (string (missing-arg) :type simple-string) (start (missing-arg) :type (and unsigned-byte fixnum)) (end (missing-arg) :type (and unsigned-byte fixnum)) (character (missing-arg) :type character) (colonp nil :type (member t nil)) (atsignp nil :type (member t nil)) (params nil :type list)) (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)))) ;;;; TOKENIZE-CONTROL-STRING (defun tokenize-control-string (string) (declare (simple-string string)) (let ((index 0) (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. (block) (pprint) (semicolon) (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)) (char (format-directive-character directive))) ;; this processing is required by CLHS 22.3.5.2 (cond ((char= char #\<) (push directive block)) ((and block (char= char #\;) (format-directive-colonp directive)) (setf semicolon directive)) ((char= char #\>) (unless block (error 'format-error :complaint "~~> without a matching ~~<" :control-string string :offset next-directive)) (cond ((format-directive-colonp directive) (unless pprint (setf pprint (car block))) (setf semicolon nil)) (semicolon (unless justification-semicolon (setf justification-semicolon semicolon)))) (pop block)) ;; block cases are handled by the #\< expander/interpreter ((not block) (case char ((#\W #\I #\_) (unless pprint (setf pprint directive))) (#\T (when (and (format-directive-colonp directive) (not pprint)) (setf pprint 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 (1- (format-directive-end justification-semicolon)))) (error 'format-error :complaint "misuse of justification and pprint directives" :control-string string :offset (min pprint-offset justification-offset) :second-relative (- (max pprint-offset justification-offset) (min pprint-offset justification-offset) 1) :references (list '(:ansi-cl :section (22 3 5 2)))))) (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))) (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 :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 :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)) (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)))))) ;;;; FORMATTER stuff (sb!xc:defmacro formatter (control-string) `#',(%formatter control-string)) (defun %formatter (control-string) (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) (declare (ignorable stream)) ,guts args)))) (let ((*orig-args-available* t) (*only-simple-args* nil)) `(lambda (stream &rest orig-args) (declare (ignorable stream)) (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))) `(block nil ,@(expand-directive-list directives)))) (defun expand-directive-list (directives) (let ((results nil) (remaining-directives directives)) (loop (unless remaining-directives (return)) (multiple-value-bind (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 (let ((char (format-directive-character directive))) (typecase char (base-char (aref *format-directive-expanders* (sb!xc:char-code char)))))) (*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))))))) (simple-string (values `(write-string ,directive stream) 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))) (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*)) (let ((symbol (sb!xc:gensym "FORMAT-ARG"))) (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 (sb!xc:gensym "FVAR"))) (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)))) ;;;; format directive machinery (eval-when (:compile-toplevel :execute) (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro def-complex-format-directive (char lambda-list &body body) (let ((defun-name (intern (format nil "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" char))) (directive (sb!xc:gensym "DIRECTIVE")) (directives (if lambda-list (car (last lambda-list)) (sb!xc:gensym "DIRECTIVES")))) `(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))) (%set-format-directive-expander ,char #',defun-name)))) (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro def-format-directive (char lambda-list &body body) (let ((directives (sb!xc:gensym "DIRECTIVES")) (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)))) ) ; EVAL-WHEN (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %set-format-directive-expander (char fn) (let ((code (sb!xc:char-code (char-upcase char)))) (setf (aref *format-directive-expanders* code) fn)) char) (defun %set-format-directive-interpreter (char fn) (let ((code (sb!xc:char-code (char-upcase char)))) (setf (aref *format-directive-interpreters* code) 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))))) ) ; EVAL-WHEN ;;;; format directives for simple output (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)) `(princ ,(if colonp `(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)))) (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))))) (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)))) ;;;; 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)) `(let ((*print-base* ,base) (*print-radix* nil) (*print-escape* nil)) (output-object ,(expand-next-arg) stream)))) (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) (expand-bind-defaults ((base nil) (mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params (let ((n-arg (sb!xc:gensym "ARG"))) `(let ((,n-arg ,(expand-next-arg))) (if ,base (format-print-integer stream ,n-arg ,colonp ,atsignp ,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 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))))) (if atsignp `(write-string (if (eql ,arg 1) "y" "ies") stream) `(unless (eql ,arg 1) (write-char #\s stream)))))) ;;;; 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.")) (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.")) (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))) (def-format-directive #\G (colonp atsignp params) (when colonp (error 'format-error :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 `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) (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))) ;;;; 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." )) (if params (expand-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 "The colon and atsign modifiers cannot be used with this directive." )) (if params (expand-bind-defaults ((count 1)) params `(progn (when (plusp ,count) (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." )) (if params (expand-bind-defaults ((count 1)) params `(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." )) (if params (expand-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 "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))) ;;;; 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)) (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))))) (def-format-directive #\_ (colonp atsignp params) (expand-bind-defaults () params `(pprint-newline ,(if colonp (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")) (expand-bind-defaults ((n 0)) params `(pprint-indent ,(if colonp :current :block) ,n stream))) ;;;; format directive for ~* (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 ~ between 0 and ~W." :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 ~ 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))))) ;;;; 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")) (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))))) ,(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)))))) ;;;; format directives for capitalization (def-complex-format-directive #\( (colonp atsignp params directives) (let ((close (find-directive directives #\) nil))) (unless close (error 'format-error :complaint "no corresponding close parenthesis")) (let* ((posn (position close 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))) after)))) (def-complex-format-directive #\) () (error 'format-error :complaint "no corresponding open parenthesis")) ;;;; format directives and support functions for conditionalization (def-complex-format-directive #\[ (colonp atsignp params directives) (multiple-value-bind (sublists last-semi-with-colon-p remaining) (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) (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))))) remaining))) (defun parse-conditional-directive (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 (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))))) (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)))) (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 *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))))) (def-complex-format-directive #\; () (error 'format-error :complaint "~~; directive not contained within either ~~[...~~] or ~~<...~~>")) (def-complex-format-directive #\] () (error 'format-error :complaint "no corresponding open bracket")) ;;;; 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")) (when (and colonp (not *up-up-and-out-allowed*)) (error 'format-error :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)) (,arg1 (eql ,arg1 0)) (t ,(if colonp '(null outside-args) (progn (setf *only-simple-args* nil) '(null args)))))) ,(if colonp '(return-from outside-loop nil) '(return)))) ;;;; format directives for iteration (def-complex-format-directive #\{ (colonp atsignp params string end 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))) (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-block count) `(let* ((orig-args ,(expand-next-arg)) (args orig-args)) (declare (ignorable orig-args args)) ,(let ((*expander-next-arg-macro* 'expander-next-arg) (*only-simple-args* nil) (*orig-args-available* t)) (compute-block count)))))) (values (if params (expand-bind-defaults ((count nil)) params (if (zerop posn) `(let ((inside-string ,(expand-next-arg))) ,(compute-bindings count)) (compute-bindings count))) (if (zerop posn) `(let ((inside-string ,(expand-next-arg))) ,(compute-bindings nil)) (compute-bindings nil))) (nthcdr (1+ posn) directives)))))) (def-complex-format-directive #\} () (error 'format-error :complaint "no corresponding open brace")) ;;;; 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"))) (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)))))) (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) :references (list '(:ansi-cl :section (22 3 5 2))))) (expand-format-justification segments colonp atsignp first-semi params))) remaining))) (def-complex-format-directive #\> () (error 'format-error :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))) (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 "cannot include format directives inside the ~ ~:[suffix~;prefix~] segment of ~~<...~~:>" :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 ~~<...~~:>"))))) (when (format-directive-atsignp close) (setf insides (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))) (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)))))) (t nil))) (defun add-fill-style-newlines-aux (literal string offset) (let ((end (length literal)) (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)))) (results)))) (defun parse-format-justification (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 (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)) (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))) (pprint-logical-block (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))))))) (defun expand-format-justification (segments colonp atsignp first-semi params) (let ((newline-segment-p (and first-semi (format-directive-colonp first-semi)))) (expand-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)))) ,(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))))) ;;;; format directive and support function for user-defined method (def-format-directive #\/ (string start end colonp atsignp params) (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 (sb!xc:gensym "PARAM"))) (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)))))) (defun extract-user-fun-name (string start end) (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 ;; 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))) (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)))) ;;; compile-time checking for argument mismatch. This code is ;;; inspired by that of Gerd Moellmann, and comes decorated with ;;; FIXMEs: (defun %compiler-walk-format-string (string args) (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)))) ;; 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 ;; simple argument count mismatch checking: when the minimum and ;; maximum argument counts are the same at a given point, we ;; know which argument is going to be used for a given ;; 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) (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))) ;; 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)))))))