1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / code / late-format.lisp

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 2fc0f3a..4f4c6b1 100644 (file)
--- 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))
@@ -350,8 +349,8 @@
 \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)))
@@ -370,8 +369,7 @@
                  ,@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)
+(#+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))
@@ -385,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)
@@ -452,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
@@ -498,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 (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
@@ -603,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)
@@ -1033,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)
@@ -1047,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)))