X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftype-class.lisp;h=d493d41f62776d3d2c9bef4271778114efde8352;hb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;hp=bf12bec17bba4d75099aff9c5d93f613f1aa7bae;hpb=67d2b80e478824a46317419f076ab1f6b020f6b1;p=sbcl.git

diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp
index bf12bec..d493d41 100644
--- a/src/code/type-class.lisp
+++ b/src/code/type-class.lisp
@@ -122,8 +122,8 @@
       (:complex-= . type-class-complex-=)
       (:unparse . type-class-unparse))))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  
+(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 ;;; Copy TYPE-CLASS object X, using only operations which will work
 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
 ;;; because it needs RAW-INDEX and RAW-LENGTH information from
@@ -147,7 +147,6 @@
 ;;; the positive effect of removing indirection could be cancelled by
 ;;; the negative effect of imposing an unnecessary GC write barrier on
 ;;; raw data which doesn't actually affect GC.)
-(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 (defun copy-type-class-coldly (x)
   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
@@ -241,11 +240,13 @@
       (let ((class1 (type-class-info type1))
 	    (class2 (type-class-info type2)))
 	(if (eq class1 class2)
-	    (funcall (funcall simple class1) type1 type2)
+	    (funcall (the function (funcall simple class1)) type1 type2)
 	    (let ((complex2 (funcall cslot2 class2)))
+              (declare (type (or function null) complex2))
 	      (if complex2
 		  (funcall complex2 type1 type2)
 		  (let ((complex1 (funcall cslot1 class1)))
+                    (declare (type (or function null) complex1))
 		    (if complex1
 			(if complex-arg1-p
 			    (funcall complex1 type1 type2)
@@ -278,11 +279,21 @@
 ;;; when no next method exists. -- WHN 2002-04-07
 ;;;
 ;;; (We miss CLOS! -- CSR and WHN)
-(defun invoke-complex-subtypep-arg1-method (type1 type2)
+(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
   (let* ((type-class (type-class-info type1))
 	 (method-fun (type-class-complex-subtypep-arg1 type-class)))
     (if method-fun
 	(funcall (the function method-fun) type1 type2)
-	(values nil nil))))
+	(values subtypep win))))
+
+;;; KLUDGE: This function is dangerous, as its overuse could easily
+;;; cause stack exhaustion through unbounded recursion.  We only use
+;;; it in one place; maybe it ought not to be a function at all?
+(defun invoke-complex-=-other-method (type1 type2)
+  (let* ((type-class (type-class-info type1))
+	 (method-fun (type-class-complex-= type-class)))
+    (if method-fun
+	(funcall (the function method-fun) type2 type1)
+	(values nil t))))
 
 (!defun-from-collected-cold-init-forms !type-class-cold-init)