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

diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp
index ae34c26..bf12bec 100644
--- a/src/code/type-class.lisp
+++ b/src/code/type-class.lisp
@@ -36,7 +36,7 @@
 			      (print-unreadable-object (x stream :type t)
 				(prin1 (type-class-name x) stream)))))
   ;; the name of this type class (used to resolve references at load time)
-  (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT?
+  (name nil :type symbol) ; FIXME: should perhaps be (MISSING-ARG) default?
   ;; Dyadic type methods. If the classes of the two types are EQ, then
   ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
   ;; either type's class has a COMPLEX-xxx method, then we call it.
@@ -100,8 +100,8 @@
   ;; supplying both.
   (unary-typep nil :type (or symbol null))
   (typep nil :type (or symbol null))
-  ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
-  ;; type.
+  ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to 
+  ;; the type.
   (unary-coerce nil :type (or symbol null))
   (coerce :type (or symbol null))
   |#
@@ -152,7 +152,7 @@
   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
   ;; have to be hand-tweaked to match. -- WHN 2001-03-19
-  (make-type-class :name                  (type-class-name x)
+  (make-type-class :name (type-class-name x)
 		   . #.(mapcan (lambda (type-class-fun-slot)
 				 (destructuring-bind (keyword . slot-accessor)
 				     type-class-fun-slot
@@ -214,15 +214,15 @@
        (%invoke-type-method ',(class-fun-slot-or-lose simple)
 			    ',(class-fun-slot-or-lose
 			       (if complex-arg1-p
-				 complex-arg1
-				 complex-arg2))
+				   complex-arg1
+				   complex-arg2))
 			    ',(class-fun-slot-or-lose complex-arg2)
 			    ,complex-arg1-p
 			    ,type1
 			    ,type2)
      (if valid-p
-       (values result-a result-b)
-       ,default)))
+	 (values result-a result-b)
+	 ,default)))
 
 ;;; most of the implementation of !INVOKE-TYPE-METHOD
 ;;;
@@ -241,20 +241,48 @@
       (let ((class1 (type-class-info type1))
 	    (class2 (type-class-info type2)))
 	(if (eq class1 class2)
-	  (funcall (funcall simple class1) type1 type2)
-	  (let ((complex2 (funcall cslot2 class2)))
-	    (if complex2
-	      (funcall complex2 type1 type2)
-	      (let ((complex1 (funcall cslot1 class1)))
-		(if complex1
-		  (if complex-arg1-p
-		    (funcall complex1 type1 type2)
-		    (funcall complex1 type2 type1))
-		  ;; No meaningful result was found: the caller should
-		  ;; use the default value instead.
-		  (return-from %invoke-type-method (values nil nil nil))))))))
+	    (funcall (funcall simple class1) type1 type2)
+	    (let ((complex2 (funcall cslot2 class2)))
+	      (if complex2
+		  (funcall complex2 type1 type2)
+		  (let ((complex1 (funcall cslot1 class1)))
+		    (if complex1
+			(if complex-arg1-p
+			    (funcall complex1 type1 type2)
+			    (funcall complex1 type2 type1))
+			;; No meaningful result was found: the caller
+			;; should use the default value instead.
+			(return-from %invoke-type-method
+			  (values nil nil nil))))))))
     ;; If we get to here (without breaking out by calling RETURN-FROM)
     ;; then a meaningful result was found, and we return it.
     (values result-a result-b t)))
 
+;;; This is a very specialized implementation of CLOS-style
+;;; CALL-NEXT-METHOD within our twisty little type class object
+;;; system, which works given that it's called from within a
+;;; COMPLEX-SUBTYPEP-ARG2 method. (We're particularly motivated to
+;;; implement CALL-NEXT-METHOD in that case, because ANSI imposes some
+;;; strict limits on when SUBTYPEP is allowed to return (VALUES NIL NIL),
+;;; so instead of just complacently returning (VALUES NIL NIL) from a
+;;; COMPLEX-SUBTYPEP-ARG2 method we usually need to CALL-NEXT-METHOD.)
+;;;
+;;; KLUDGE: In CLOS, this could just be CALL-NEXT-METHOD and
+;;; everything would Just Work without us having to think about it. In
+;;; our goofy type dispatch system, it's messier to express. It's also
+;;; more fragile, since (0) there's no check that it's called from
+;;; within a COMPLEX-SUBTYPEP-ARG2 method as it should be, and (1) we
+;;; rely on our global knowledge that the next (and only) relevant
+;;; method is COMPLEX-SUBTYPEP-ARG1, and (2) we rely on our global
+;;; knowledge of the appropriate default for the CSUBTYPEP function
+;;; when no next method exists. -- WHN 2002-04-07
+;;;
+;;; (We miss CLOS! -- CSR and WHN)
+(defun invoke-complex-subtypep-arg1-method (type1 type2)
+  (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))))
+
 (!defun-from-collected-cold-init-forms !type-class-cold-init)