X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Ftypetran.lisp;h=89d156807546a17855b1cfdfbeaadac82c832ad7;hb=095a47764e687fa76cf0e2803633d30c65c00f40;hp=3956ca8148c41562e8f15796208bdf71a7954cb4;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 3956ca8..89d1568 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -148,6 +148,9 @@
 
 (define-source-transform atom (x)
   `(not (consp ,x)))
+#!+sb-unicode
+(define-source-transform base-char-p (x)
+  `(typep ,x 'base-char))
 
 ;;;; TYPEP source transform
 
@@ -243,13 +246,13 @@
 
 ;;; Do source transformation for TYPEP of a known union type. If a
 ;;; union type contains LIST, then we pull that out and make it into a
-;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
-;;; will be a subtype even without there being any (member NIL). We
-;;; just drop through to the general code in this case, rather than
-;;; trying to optimize it.
+;;; single LISTP call.  Note that if SYMBOL is in the union, then LIST
+;;; will be a subtype even without there being any (member NIL).  We
+;;; currently just drop through to the general code in this case,
+;;; rather than trying to optimize it (but FIXME CSR 2004-04-05: it
+;;; wouldn't be hard to optimize it after all).
 (defun source-transform-union-typep (object type)
   (let* ((types (union-type-types type))
-	 (type-list (specifier-type 'list))
          (type-cons (specifier-type 'cons))
 	 (mtype (find-if #'member-type-p types))
          (members (when mtype (member-type-members mtype))))
@@ -292,6 +295,21 @@
 			`((typep (cdr ,n-obj)
 				 ',(type-specifier cdr-type))))))))))
  
+(defun source-transform-character-set-typep (object type)
+  (let ((pairs (character-set-type-pairs type)))
+    (if (and (= (length pairs) 1)
+            (= (caar pairs) 0)
+            (= (cdar pairs) (1- sb!xc:char-code-limit)))
+       `(characterp ,object)
+       (once-only ((n-obj object))
+         (let ((n-code (gensym "CODE")))
+           `(and (characterp ,n-obj)
+                 (let ((,n-code (sb!xc:char-code ,n-obj)))
+                   (or
+                    ,@(loop for pair in pairs
+                            collect
+                            `(<= ,(car pair) ,n-code ,(cdr pair)))))))))))
+
 ;;; Return the predicate and type from the most specific entry in
 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 (defun find-supertype-predicate (type)
@@ -371,7 +389,7 @@
       ;; If not properly named, error.
       ((not (and name (eq (find-classoid name) class)))
        (compiler-error "can't compile TYPEP of anonymous or undefined ~
-			class:~%  ~S"
+                        class:~%  ~S"
 		       class))
       (t
         ;; Delay the type transform to give type propagation a chance.
@@ -493,6 +511,8 @@
 	       (source-transform-array-typep object type))
 	      (cons-type
 	       (source-transform-cons-typep object type))
+             (character-set-type
+              (source-transform-character-set-typep object type))
 	      (t nil))
 	    `(%typep ,object ,spec)))
       (values nil t)))