X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftypetran.lisp;h=612d2bcc199e1e95e52d32c141e19da67a240122;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=5503f875d3617e4084119275bd185e6b7f90024f;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 5503f87..612d2bc 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
 
@@ -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)
@@ -309,12 +327,13 @@
 
 ;;; Return forms to test that OBJ has the rank and dimensions
 ;;; specified by TYPE, where STYPE is the type we have checked against
-;;; (which is the same but for dimensions.)
+;;; (which is the same but for dimensions and element type).
 (defun test-array-dimensions (obj type stype)
   (declare (type array-type type stype))
   (let ((obj `(truly-the ,(type-specifier stype) ,obj))
 	(dims (array-type-dimensions type)))
-    (unless (eq dims '*)
+    (unless (or (eq dims '*)
+		(equal dims (array-type-dimensions stype)))
       (collect ((res))
 	(when (eq (array-type-dimensions stype) '*)
 	  (res `(= (array-rank ,obj) ,(length dims))))
@@ -326,6 +345,24 @@
 	      (res `(= (array-dimension ,obj ,i) ,dim)))))
 	(res)))))
 
+;;; Return forms to test that OBJ has the element-type specified by
+;;; type specified by TYPE, where STYPE is the type we have checked
+;;; against (which is the same but for dimensions and element type).
+(defun test-array-element-type (obj type stype)
+  (declare (type array-type type stype))
+  (let ((obj `(truly-the ,(type-specifier stype) ,obj))
+	(eltype (array-type-specialized-element-type type)))
+    (unless (type= eltype (array-type-specialized-element-type stype))
+      (with-unique-names (data)
+	`((do ((,data ,obj (%array-data-vector ,data)))
+	      ((not (array-header-p ,data))
+	       ;; KLUDGE: this isn't in fact maximally efficient,
+	       ;; because though we know that DATA is a (SIMPLE-ARRAY *
+	       ;; (*)), we will still check to see if the lowtag is
+	       ;; appropriate.
+	       (typep ,data
+		      '(simple-array ,(type-specifier eltype) (*))))))))))
+
 ;;; If we can find a type predicate that tests for the type without
 ;;; dimensions, then use that predicate and test for dimensions.
 ;;; Otherwise, just do %TYPEP.
@@ -336,12 +373,11 @@
 	     ;; not safe to assume here that it will eventually
 	     ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
 	     (not (unknown-type-p (array-type-element-type type)))
-	     (type= (array-type-specialized-element-type stype)
-		    (array-type-specialized-element-type type))
 	     (eq (array-type-complexp stype) (array-type-complexp type)))
 	(once-only ((n-obj obj))
 	  `(and (,pred ,n-obj)
-		,@(test-array-dimensions n-obj type stype)))
+	        ,@(test-array-dimensions n-obj type stype)
+	        ,@(test-array-element-type n-obj type stype)))
 	`(%typep ,obj ',(type-specifier type)))))
 
 ;;; Transform a type test against some instance type. The type test is
@@ -478,7 +514,7 @@
 	      (intersection-type
 	       (source-transform-intersection-typep object type))
 	      (member-type
-	       `(member ,object ',(member-type-members type)))
+	       `(if (member ,object ',(member-type-members type)) t))
 	      (args-type
 	       (compiler-warn "illegal type specifier for TYPEP: ~S"
 			      (cadr spec))
@@ -493,12 +529,24 @@
 	       (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)))
 
 ;;;; coercion
 
+;;; Constant-folding.
+;;;
+#-sb-xc-host
+(defoptimizer (coerce optimizer) ((x type) node)
+  (when (and (constant-lvar-p x) (constant-lvar-p type))
+    (let ((value (lvar-value x)))
+      (when (or (numberp value) (characterp value))
+        (constant-fold-call node)
+        t))))
+
 (deftransform coerce ((x type) (* *) * :node node)
   (unless (constant-lvar-p type)
     (give-up-ir1-transform))