X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Ftypetran.lisp;h=e1071a821ab2f8d551c1190f5d2b588cb347fbb1;hb=1d941f3d8f343f5779526b66b2358b4893a17281;hp=1b48fea0ed312c8b97bd4785bfc56304b8e2b2d5;hpb=5eb97830eca716fef626c6e12429c99c9b97e3c8;p=sbcl.git

diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 1b48fea..e1071a8 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -148,9 +148,10 @@
 
 ;;;; TYPEP source transform
 
-;;; Return a form that tests the variable N-Object for being in the binds
-;;; specified by Type. Base is the name of the base type, for declaration. We
-;;; make safety locally 0 to inhibit any checking of this assertion.
+;;; Return a form that tests the variable N-OBJECT for being in the
+;;; binds specified by TYPE. BASE is the name of the base type, for
+;;; declaration. We make SAFETY locally 0 to inhibit any checking of
+;;; this assertion.
 #!-negative-zero-is-not-zero
 (defun transform-numeric-bound-test (n-object type base)
   (declare (type numeric-type type))
@@ -259,7 +260,7 @@
   (declare (type hairy-type type))
   (let ((spec (hairy-type-specifier type)))
     (cond ((unknown-type-p type)
-	   (when (policy nil (> speed brevity))
+	   (when (policy nil (> speed inhibit-warnings))
 	     (compiler-note "can't open-code test of unknown type ~S"
 			    (type-specifier type)))
 	   `(%typep ,object ',spec))
@@ -272,7 +273,7 @@
 					      `(typep ,n-obj ',x))
 					  (rest spec))))))))))
 
-;;; Do source transformation for Typep of a known union type. If a
+;;; 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
@@ -298,30 +299,25 @@
 				`(typep ,n-obj ',(type-specifier x)))
 			    types)))))))
 
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
-; ;;; Source-Transform-Cons-Typep
-; ;;;
-; ;;; If necessary recurse to check the cons type.
-; ;;;
-; (defun source-transform-cons-typep (object type)
-;   (let* ((car-type (cons-type-car-type type))
-;  	 (cdr-type (cons-type-cdr-type type)))
-;     (let ((car-test-p (not (or (type= car-type *wild-type*)
-;  			       (type= car-type (specifier-type t)))))
-;  	  (cdr-test-p (not (or (type= cdr-type *wild-type*)
-;  			       (type= cdr-type (specifier-type t))))))
-;       (if (and (not car-test-p) (not cdr-test-p))
-;         `(consp ,object)
-;         (once-only ((n-obj object))
-;                    `(and (consp ,n-obj)
-;                      ,@(if car-test-p
-;                            `((typep (car ,n-obj)
-;                               ',(type-specifier car-type))))
-;                      ,@(if cdr-test-p
-;                            `((typep (cdr ,n-obj)
-;                               ',(type-specifier cdr-type))))))))))
-
+;;; If necessary recurse to check the cons type.
+(defun source-transform-cons-typep (object type)
+  (let* ((car-type (cons-type-car-type type))
+	 (cdr-type (cons-type-cdr-type type)))
+    (let ((car-test-p (not (or (type= car-type *wild-type*)
+			       (type= car-type (specifier-type t)))))
+	  (cdr-test-p (not (or (type= cdr-type *wild-type*)
+			       (type= cdr-type (specifier-type t))))))
+      (if (and (not car-test-p) (not cdr-test-p))
+	  `(consp ,object)
+	  (once-only ((n-obj object))
+	    `(and (consp ,n-obj)
+		  ,@(if car-test-p
+			`((typep (car ,n-obj)
+				 ',(type-specifier car-type))))
+		  ,@(if cdr-test-p
+			`((typep (cdr ,n-obj)
+				 ',(type-specifier cdr-type))))))))))
+ 
 ;;; Return the predicate and type from the most specific entry in
 ;;; *TYPE-PREDICATES* that is a supertype of TYPE.
 (defun find-supertype-predicate (type)
@@ -464,19 +460,6 @@
 				    ',(find-class-cell name)
 				    object)))))))))
 
-#|
-;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
-;;; which corresponds to the value returned by
-;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
-;;; result might change when we encounter a DEFTYPE.
-(declaim (maybe-inline upgraded-array-element-ctype-2))
-(defun upgraded-array-element-ctype-2 (spec)
-  (let ((ctype (specifier-type `(array ,spec))))
-    (values (array-type-specialized-element-type
-	     (specifier-type `(array ,spec)))
-	    (not (unknown-type-p (array-type-element-type ctype))))))
-|#
-
 ;;; If the specifier argument is a quoted constant, then we consider
 ;;; converting into a simple predicate or other stuff. If the type is
 ;;; constant, but we can't transform the call, then we convert to
@@ -519,10 +502,8 @@
 		    `(%instance-typep ,object ,spec))
 		   (array-type
 		    (source-transform-array-typep object type))
-                   ;; MNA: cons compound-type patch
-                   ;; FIXIT: all commented
-;                    (cons-type
-;                     (source-transform-cons-typep object type))                   
+		   (cons-type
+		    (source-transform-cons-typep object type))
 		   (t nil)))
 	    `(%typep ,object ,spec)))
       (values nil t)))
@@ -548,6 +529,7 @@
 		      (give-up-ir1-transform)))))))
 
 ;;; KLUDGE: new broken version -- 20000504
+;;; FIXME: should be fixed or deleted
 #+nil
 (deftransform coerce ((x type) (* *) * :when :both)
   (unless (constant-continuation-p type)