Changeset 12947 for branches/working-0711/ccl/lib/chars.lisp

Timestamp:

Oct 9, 2009, 5:28:00 PM (11 years ago)

Author:

gz

Message:

Don't accept integers as character designators (r12764)

File:

• branches/working-0711/ccl/lib/chars.lisp (modified) (2 diffs)

branches/working-0711/ccl/lib/chars.lisp

@@ -18 +18 @@
 (in-package "CCL")
 
-; If object is a character, it is returned.  If it is an integer, its INT-CHAR
-; is returned. If it is a string of length 1, then the sole element of the
-; string is returned.  If it is a symbol whose pname is of length 1, then
-; the sole element of the pname is returned. Else error.
+(defun character-designator-p (thing)
+  (or (typep thing 'character)
+      (typep thing '(string 1))
+      (and (typep thing 'symbol) (typep (symbol-name thing) '(string 1)))))
+
+;;; If object is a character, it is returned.  If it is a string of
+;;; length 1, then the sole element of the string is returned.  If it
+;;; is a symbol whose pname is of length 1, then the sole element of
+;;; the pname is returned. Else error.
 
 (defun character (arg)
@@ -28 +33 @@
   (if (typep arg 'character)
     arg
-    (if (typep arg 'fixnum)
-      (code-char arg)
-      (if (and (typep arg 'string)
-               (= (the fixnum (length arg)) 1))
-        (char arg 0)
-        (let* ((pname (if (typep arg 'symbol) (symbol-name arg))))
-          (if (and pname (= (the fixnum (length pname)) 1))
-            (char pname 0)
-            (%err-disp $xcoerce arg 'character)))))))
+    (if (and (typep arg 'string)
+             (= (the fixnum (length arg)) 1))
+      (char arg 0)
+      (let* ((pname (if (typep arg 'symbol) (symbol-name arg))))
+        (if (and pname (= (the fixnum (length pname)) 1))
+          (char pname 0)
+          (report-bad-arg arg '(satisfies character-designator-p)))))))