: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)))))
(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))
`(,*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)))
(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
\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)
+(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
,@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
,@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)
(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
`(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)))
+ `(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 #\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
(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)
(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)
: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)))
(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
projects / sbcl.git / blobdiff