X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftypecheckfuns.lisp;h=e4a0d8b15b1c69275c82a2411f5d7c2e154c94dc;hb=3fe0010d2777b41e01ea9b4a0f894cfa40f7df1b;hp=e398b70fdc353476206fe2c58563ece863724f64;hpb=a37de74b393a808825585000bb5b2b92218d46c0;p=sbcl.git

diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp
index e398b70..e4a0d8b 100644
--- a/src/code/typecheckfuns.lisp
+++ b/src/code/typecheckfuns.lisp
@@ -122,7 +122,7 @@
 
 ;;; Memoize the FORM which returns a typecheckfun for TYPESPEC.
 (defmacro memoized-typecheckfun-form (form typespec)
-  (let ((n-typespec (gensym "TYPESPEC")))
+  (with-unique-names (n-typespec)
     `(let ((,n-typespec ,typespec))
        (or (gethash ,n-typespec *typecheckfuns*)
 	   (setf (gethash ,n-typespec *typecheckfuns*)
@@ -130,20 +130,26 @@
 
 #+sb-xc
 (defun !typecheckfuns-cold-init ()
+  (/show0 "in typecheckfuns-cold-init")
   (setf *typecheckfuns* (make-hash-table :test 'equal))
   ;; Initialize the table of common typespecs.
   (setf *common-typespecs* #.*compile-time-common-typespecs*)
   ;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs.
+  (/show0 "typecheckfuns-cold-init initial setfs done")
   (macrolet ((macro ()
 	       `(progn
 		  ,@(map 'list
 			 (lambda (typespec)
-			   `(setf (gethash ',typespec *typecheckfuns*)
-				  (lambda (arg)
-				    (unless (typep arg ',typespec)
-				      (typecheck-failure arg ',typespec))
-				    (values))))
-			 *common-typespecs*))))
+			   `(progn
+                              (/show0 "setf")
+                              (setf (gethash ',typespec *typecheckfuns*)
+                                    (progn
+                                      (/show0 "lambda")
+                                      (lambda (arg)                                      
+                                        (unless (typep arg ',typespec)
+                                          (typecheck-failure arg ',typespec))
+                                        (values))))))
+                         *common-typespecs*))))
     (macro))
   (values))
 
@@ -186,11 +192,11 @@
       (setf (gethash typespec *typecheckfuns*) unmemoized-typecheckfun)
       ;; UNMEMOIZED-TYPECHECKFUN shouldn't be NIL unless the compiler
       ;; knew that the memo would exist, so we shouldn't be here.
-      (error "internal error: no typecheckfun memo for ~%  ~S" typespec)))
+      (bug "no typecheckfun memo for ~S" typespec)))
 
 (defun ctype-needs-to-be-interpreted-p (ctype)
   ;; What we should really do is factor out the code in
-  ;; (DEF-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here.
+  ;; (DEFINE-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here.
   ;; Until then this toy version should be good enough for some testing.
   (warn "FIXME: This is just a toy stub CTYPE-NEEDS-TO-BE-INTERPRETED-P.")
   (not (or (position (type-specifier ctype)
@@ -199,7 +205,11 @@
 	   (member-type-p ctype)
 	   (numeric-type-p ctype)
 	   (array-type-p ctype)
-	   (cons-type-p ctype))))
+           (cons-type-p ctype)
+           (intersection-type-p ctype)
+           (union-type-p ctype)
+           (negation-type-p ctype)
+           (character-set-type-p ctype))))
 
 ;;; Evaluate (at load/execute time) to a function which checks that
 ;;; its argument is of the specified type.
@@ -207,7 +217,7 @@
 ;;; The name is slightly misleading, since some cases are memoized, so
 ;;; we might reuse a value which was made earlier instead of creating
 ;;; a new one from scratch.
-(declaim (ftype (function (t) function) typespec-typecheckfun))
+(declaim (ftype (sfunction (t) function) typespec-typecheckfun))
 (defun typespec-typecheckfun (typespec)
   ;; a general-purpose default case, hopefully overridden by the
   ;; DEFINE-COMPILER-MACRO implementation
@@ -221,7 +231,7 @@
       (let* ((typespec (second typespec-form))
 	     (ctype (specifier-type typespec)))
 	(aver (= 2 (length typespec-form)))
-	(cond ((structure-class-p ctype)
+	(cond ((structure-classoid-p ctype)
 	       `(structure-object-typecheckfun ,typespec-form))
 	      ((ctype-needs-to-be-interpreted-p ctype)
 	       whole) ; i.e. give up compiler macro