X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-format.lisp;h=4f4c6b12d933316af214b491f25ad5e2c8005878;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=8c5c0c5c4dcb2b356e12e4dbb5b7ace4133d5182;hpb=d7eeed8e500932c38cd2c7d22ea1ff9630d2f7c8;p=sbcl.git diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 8c5c0c5..4f4c6b1 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -279,8 +279,7 @@ (let ((char (format-directive-character directive))) (typecase char (base-char - (aref *format-directive-expanders* (char-code char))) - (character nil)))) + (aref *format-directive-expanders* (sb!xc:char-code char)))))) (*default-format-error-offset* (1- (format-directive-end directive)))) (declare (type (or null function) expander)) @@ -306,7 +305,7 @@ `(,*expander-next-arg-macro* ,*default-format-error-control-string* ,(or offset *default-format-error-offset*)) - (let ((symbol (gensym "FORMAT-ARG-"))) + (let ((symbol (sb!xc:gensym "FORMAT-ARG"))) (push (cons symbol (or offset *default-format-error-offset*)) *simple-args*) symbol))) @@ -315,34 +314,32 @@ (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))) + (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 @@ -352,13 +349,13 @@ ;;;; 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) +(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 (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) + (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 @@ -372,9 +369,8 @@ ,@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)) +(#+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 @@ -387,17 +383,18 @@ ,@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) - (setf (aref *format-directive-expanders* (char-code (char-upcase 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) - (setf (aref *format-directive-interpreters* - (char-code (char-upcase 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) @@ -454,13 +451,22 @@ (t `(prin1 ,(expand-next-arg) stream)))) -(def-format-directive #\C (colonp atsignp params) +(def-format-directive #\C (colonp atsignp params string end) (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))))) + (let ((n-arg (sb!xc:gensym "ARG"))) + `(let ((,n-arg ,(expand-next-arg))) + (unless (typep ,n-arg 'character) + (error 'format-error + :complaint "~s is not of type CHARACTER." + :args (list ,n-arg) + :control-string ,string + :offset ,(1- end))) + ,(cond (colonp + `(format-print-named-character ,n-arg stream)) + (atsignp + `(prin1 ,n-arg stream)) + (t + `(write-char ,n-arg stream))))))) (def-format-directive #\W (colonp atsignp params) (expand-bind-defaults () params @@ -500,13 +506,20 @@ (def-format-directive #\X (colonp atsignp params) (expand-format-integer 16 colonp atsignp params)) -(def-format-directive #\R (colonp atsignp params) +(def-format-directive #\R (colonp atsignp params string end) (expand-bind-defaults ((base nil) (mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params - (let ((n-arg (gensym))) + (let ((n-arg (sb!xc:gensym "ARG"))) `(let ((,n-arg ,(expand-next-arg))) + (unless (or ,base + (integerp ,n-arg)) + (error 'format-error + :complaint "~s is not of type INTEGER." + :args (list ,n-arg) + :control-string ,string + :offset ,(1- end))) (if ,base (format-print-integer stream ,n-arg ,colonp ,atsignp ,base ,mincol @@ -605,9 +618,10 @@ (if params (expand-bind-defaults ((count 1)) params `(progn - (fresh-line stream) - (dotimes (i (1- ,count)) - (terpri stream)))) + (when (plusp ,count) + (fresh-line stream) + (dotimes (i (1- ,count)) + (terpri stream))))) '(fresh-line stream))) (def-format-directive #\| (colonp atsignp params) @@ -1035,7 +1049,7 @@ (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (values - (if (format-directive-colonp close) + (if (format-directive-colonp close) ; logical block vs. justification (multiple-value-bind (prefix per-line-p insides suffix) (parse-format-logical-block segments colonp first-semi close params string end) @@ -1049,6 +1063,16 @@ :complaint "~D illegal directive~:P found inside justification block" :args (list count) :references (list '(:ansi-cl :section (22 3 5 2))))) + ;; ANSI does not explicitly say that an error should be + ;; signalled, but the @ modifier is not explicitly allowed + ;; for ~> either. + (when (format-directive-atsignp close) + (error 'format-error + :complaint "@ modifier not allowed in close ~ + directive of justification ~ + block (i.e. ~~<...~~@>." + :offset (1- (format-directive-end close)) + :references (list '(:ansi-cl :section (22 3 6 2))))) (expand-format-justification segments colonp atsignp first-semi params))) remaining))) @@ -1249,7 +1273,7 @@ (collect ((param-names) (bindings)) (dolist (param-and-offset params) (let ((param (cdr param-and-offset))) - (let ((param-name (gensym))) + (let ((param-name (sb!xc:gensym "PARAM"))) (param-names param-name) (bindings `(,param-name ,(case param