From: Stas Boukarev <stassats@gmail.com>
Date: Thu, 10 Jan 2013 20:26:32 +0000 (+0400)
Subject: format: Check types for ~C and ~R.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6f4c867e670a3c538b4072b824fa8026e9f2cbfe;p=sbcl.git

format: Check types for ~C and ~R.

Both require arguments to be characters and integers respectively.
---

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 2024d07..9afc2a5 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -451,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
@@ -497,13 +506,19 @@
 (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 (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
diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 7ed2b55..399feb0 100644
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -234,11 +234,17 @@
 
 (def-format-interpreter #\C (colonp atsignp params)
   (interpret-bind-defaults () params
-    (if colonp
-        (format-print-named-character (next-arg) stream)
-        (if atsignp
-            (prin1 (next-arg) stream)
-            (write-char (next-arg) stream)))))
+    (let ((arg (next-arg)))
+      (unless (typep arg 'character)
+        (error 'format-error
+               :complaint "~s is not of type CHARACTER."
+               :args (list arg)))
+      (cond (colonp
+             (format-print-named-character arg stream))
+            (atsignp
+             (prin1 arg stream))
+            (t
+             (write-char arg stream))))))
 
 ;;; "printing" as defined in the ANSI CL glossary, which is normative.
 (defun char-printing-p (char)
@@ -326,6 +332,10 @@
        (commainterval 3))
       params
     (let ((arg (next-arg)))
+      (unless (integerp arg)
+        (error 'format-error
+               :complaint "~s is not of type INTEGER."
+               :args (list arg)))
       (if base
           (format-print-integer stream arg colonp atsignp base mincol
                                 padchar commachar commainterval)
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 8fd8bad..2e5b391 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -645,4 +645,8 @@
     (timeout ()
       (error "Endless loop in FORMAT"))))
 
+(with-test (:name :format-type-check)
+  (assert (raises-error? (format nil "~r" 1.32) sb-format:format-error))
+  (assert (raises-error? (format nil "~c" 1.32) sb-format:format-error)))
+
 ;;; success