Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

Diff of /src/clos/kernel.lsp [ed78ec] .. [53ffe3] Maximize Restore

  Switch to side-by-side view

--- a/src/clos/kernel.lsp
+++ b/src/clos/kernel.lsp
@@ -196,10 +196,19 @@
 ;;; ----------------------------------------------------------------------
 ;;; COMPUTE-APPLICABLE-METHODS
 ;;;
-;;; FIXME! This should be split int an internal function, like
-;;; raw-compute-... and a higher level interface, because the current
-;;; version does not check _any_ of the arguments but it is
-;;; nevertheless exported by the ANSI specification!
+;;; This part is a source of problems because we have to access slots of
+;;; various objects, which could potentially lead to infinite recursion as
+;;; those accessors require also some dispatch. The solution is to avoid
+;;; calling then generic function that implement the accessors.
+;;; This is possible because:
+;;;   1. The user can only extend compute-applicable-methods if it
+;;;      defines a method with a subclass of standard-generic-function
+;;;   2. The user cannot extend slot-value and friends on standard-classes
+;;;      due to the restriction "Any method defined by a portable program
+;;;      on a specified generic function must have at least one specializer
+;;;      that is neither a specified class nor an eql specializer whose
+;;;      associated value is an instance of a specified class."
+;;;   3. Subclasses of specified classes preserve the slot order in ECL.
 ;;;
 (defun std-compute-applicable-methods (gf args)
   (sort-applicable-methods gf (applicable-method-list gf args) args))
@@ -209,76 +218,73 @@
 (defun applicable-method-list (gf args)
   (declare (optimize (speed 3))
 	   (si::c-local))
-  (flet ((applicable-method-p (method args)
-	   #+(or)
-	   (print `(= ,(mapcar #'class-id (mapcar #'class-of args))
-		      ,(mapcar #'class-id (method-specializers method))))
-	   (loop for spec in (method-specializers method)
-	      for arg in args
-	      always (if (eql-specializer-flag spec)
-			 (eql arg (eql-specializer-object spec))
-			 (si::of-class-p arg spec)))))
-    (loop for method in (generic-function-methods gf)
-       when (applicable-method-p method args)
-       collect method)))
+  (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
+    (flet ((applicable-method-p (method args)
+	     (loop for spec in (method-specializers method)
+		for arg in args
+		always (if (eql-specializer-flag spec)
+			   (eql arg (eql-specializer-object spec))
+			   (si::of-class-p arg spec)))))
+      (loop for method in (generic-function-methods gf)
+	 when (applicable-method-p method args)
+	 collect method))))
 
 (defun std-compute-applicable-methods-using-classes (gf classes)
   (declare (optimize (speed 3)))
-  (flet ((applicable-method-p (method classes)
-	   (loop for spec in (method-specializers method)
-	      for class in classes
-	      always (cond ((eql-specializer-flag spec)
-			    ;; EQL specializer invalidate computation
-			    ;; we return NIL
-			    (when (si::of-class-p (eql-specializer-object spec) class)
-			      (return-from std-compute-applicable-methods-using-classes
-				(values nil nil)))
-			    nil)
-			   ((si::subclassp class spec))))))
-    (values (sort-applicable-methods
-	     gf
-	     (loop for method in (generic-function-methods gf)
-		when (applicable-method-p method classes)
-		collect method)
-	     classes)
-	    t)))
+  (with-early-accessors (+standard-method-slots+ +eql-specializer-slots+ +standard-generic-function-slots+)
+    (flet ((applicable-method-p (method classes)
+	     (loop for spec in (method-specializers method)
+		for class in classes
+		always (cond ((eql-specializer-flag spec)
+			      ;; EQL specializer invalidate computation
+			      ;; we return NIL
+			      (when (si::of-class-p (eql-specializer-object spec) class)
+				(return-from std-compute-applicable-methods-using-classes
+				  (values nil nil)))
+			      nil)
+			     ((si::subclassp class spec))))))
+      (values (sort-applicable-methods
+	       gf
+	       (loop for method in (generic-function-methods gf)
+		  when (applicable-method-p method classes)
+		  collect method)
+	       classes)
+	      t))))
 
 (defun sort-applicable-methods (gf applicable-list args)
   (declare (optimize (safety 0) (speed 3)))
-  #+(or)
-  (unless applicable-list
-    (print (generic-function-name gf))
-    (print (mapcar #'type-of args)))
-  (let ((f (generic-function-a-p-o-function gf))
-	(args-specializers (mapcar #'class-of args)))
-    ;; reorder args to match the precedence order
-    (when f
-      (setf args-specializers
-	    (funcall f (subseq args-specializers 0
-			       (length (generic-function-argument-precedence-order gf))))))
-    ;; then order the list
-    (do* ((scan applicable-list)
-	  (most-specific (first scan) (first scan))
-	  (ordered-list))
-	 ((null (cdr scan))
-	  (when most-specific
-	    ;; at least one method
-	    (nreverse
-	     (push most-specific ordered-list))))
-      (dolist (meth (cdr scan))
-	(when (eq (compare-methods most-specific
-				   meth args-specializers f) 2)
-	  (setq most-specific meth)))
-      (setq scan (delete most-specific scan))
-      (push most-specific ordered-list))))
+  (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
+    (let ((f (generic-function-a-p-o-function gf))
+	  (args-specializers (mapcar #'class-of args)))
+      ;; reorder args to match the precedence order
+      (when f
+	(setf args-specializers
+	      (funcall f (subseq args-specializers 0
+				 (length (generic-function-argument-precedence-order gf))))))
+      ;; then order the list
+      (do* ((scan applicable-list)
+	    (most-specific (first scan) (first scan))
+	    (ordered-list))
+	   ((null (cdr scan))
+	    (when most-specific
+	      ;; at least one method
+	      (nreverse
+	       (push most-specific ordered-list))))
+	(dolist (meth (cdr scan))
+	  (when (eq (compare-methods most-specific
+				     meth args-specializers f) 2)
+	    (setq most-specific meth)))
+	(setq scan (delete most-specific scan))
+	(push most-specific ordered-list)))))
 
 (defun compare-methods (method-1 method-2 args-specializers f)
   (declare (si::c-local))
-  (let* ((specializers-list-1 (method-specializers method-1))
-	 (specializers-list-2 (method-specializers method-2)))
-    (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
-				(if f (funcall f specializers-list-2) specializers-list-2)
-				args-specializers)))
+  (with-early-accessors (+standard-method-slots+)
+    (let* ((specializers-list-1 (method-specializers method-1))
+	   (specializers-list-2 (method-specializers method-2)))
+      (compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
+				  (if f (funcall f specializers-list-2) specializers-list-2)
+				  args-specializers))))
 
 (defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers)
   (declare (si::c-local))
@@ -304,83 +310,77 @@
   (declare (si::c-local))
   ;; Specialized version of subtypep which uses the fact that spec1
   ;; and spec2 are either classes or of the form (EQL x)
-  (if (eql-specializer-flag spec1)
-      (if (eql-specializer-flag spec2)
-	  (eql (eql-specializer-object spec1)
-	       (eql-specializer-object spec2))
-	  (si::of-class-p (eql-specializer-object spec1) spec2))
-      (if (eql-specializer-flag spec2)
-	  ;; There is only one class with a single element, which
-	  ;; is NULL = (MEMBER NIL).
-	  (and (null (eql-specializer-object spec2))
-	       (eq (class-name spec1) 'null))
-	  (si::subclassp spec1 spec2)))
-  #+(or)
-  (if (atom spec1)
-      (if (atom spec2)
-	  (si::subclassp spec1 spec2)
-	  ;; There is only one class with a single element, which
-	  ;; is NULL = (MEMBER NIL).
-	  (and (null (second spec2))
-	       (eq (class-name spec1) 'null)))
-      (if (atom spec2)
-	  (si::of-class-p (second spec1) spec2)
-	  (eql (second spec1) (second spec2)))))
+  (with-early-accessors (+eql-specializer-slots+ +standard-class-slots+)
+    (if (eql-specializer-flag spec1)
+	(if (eql-specializer-flag spec2)
+	    (eql (eql-specializer-object spec1)
+		 (eql-specializer-object spec2))
+	    (si::of-class-p (eql-specializer-object spec1) spec2))
+	(if (eql-specializer-flag spec2)
+	    ;; There is only one class with a single element, which
+	    ;; is NULL = (MEMBER NIL).
+	    (and (null (eql-specializer-object spec2))
+		 (eq (class-name spec1) 'null))
+	    (si::subclassp spec1 spec2)))))
 
 (defun compare-specializers (spec-1 spec-2 arg-class)
   (declare (si::c-local))
-  (let* ((cpl (class-precedence-list arg-class)))
-    (cond ((eq spec-1 spec-2) '=)
-	  ((fast-subtypep spec-1 spec-2) '1)
-	  ((fast-subtypep spec-2 spec-1) '2)
-	  ((eql-specializer-flag spec-1) '1) ; is this engough?
-	  ((eql-specializer-flag spec-2) '2) ; Beppe
-	  ((member spec-1 (member spec-2 cpl)) '2)
-	  ((member spec-2 (member spec-1 cpl)) '1)
-	  ;; This will force an error in the caller
-	  (t nil))))
+  (with-early-accessors (+standard-class-slots+ +standard-class-slots+)
+    (let* ((cpl (class-precedence-list arg-class)))
+      (cond ((eq spec-1 spec-2) '=)
+	    ((fast-subtypep spec-1 spec-2) '1)
+	    ((fast-subtypep spec-2 spec-1) '2)
+	    ((eql-specializer-flag spec-1) '1) ; is this engough?
+	    ((eql-specializer-flag spec-2) '2) ; Beppe
+	    ((member spec-1 (member spec-2 cpl)) '2)
+	    ((member spec-2 (member spec-1 cpl)) '1)
+	    ;; This will force an error in the caller
+	    (t nil)))))
 
 (defun compute-g-f-spec-list (gf)
-  (flet ((nupdate-spec-how-list (spec-how-list specializers gf)
-	   ;; update the spec-how of the gfun 
-	   ;; computing the or of the previous value and the new one
-	   (setf spec-how-list (or spec-how-list
-				   (copy-list specializers)))
-	   (do* ((l specializers (cdr l))
-		 (l2 spec-how-list (cdr l2))
-		 (spec-how)
-		 (spec-how-old))
-		((null l))
-	     (setq spec-how (first l) spec-how-old (first l2))
-	     (setf (first l2)
-		   (if (eql-specializer-flag spec-how)
-		       (list* (eql-specializer-object spec-how)
-			      (and (consp spec-how-old) spec-how-old))
-		       (if (consp spec-how-old)
-			   spec-how-old
-			   spec-how))))
-	   spec-how-list))
-  (let* ((spec-how-list nil)
-	 (function nil)
-	 (a-p-o (generic-function-argument-precedence-order gf)))
-    (dolist (method (generic-function-methods gf))
-      (setf spec-how-list
-	    (nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
-    (setf (generic-function-spec-list gf)
-	  (loop for type in spec-how-list
-		for i from 0
-		when type collect (cons type i)))
-    (let* ((g-f-l-l (generic-function-lambda-list gf)))
-      (when (consp g-f-l-l)
-	(let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
-	  (unless (equal a-p-o required-arguments)
-	    (setf function
-		  (coerce `(lambda (%list)
-			    (destructuring-bind ,required-arguments %list
-			      (list ,@a-p-o)))
-			  'function))))))
-    (setf (generic-function-a-p-o-function gf) function)
-    (si:clear-gfun-hash gf))))
+  (with-early-accessors (+standard-generic-function-slots+
+			 +eql-specializer-slots+
+			 +standard-method-slots+)
+    (flet ((nupdate-spec-how-list (spec-how-list specializers gf)
+	     ;; update the spec-how of the gfun 
+	     ;; computing the or of the previous value and the new one
+	     (setf spec-how-list (or spec-how-list
+				     (copy-list specializers)))
+	     (do* ((l specializers (cdr l))
+		   (l2 spec-how-list (cdr l2))
+		   (spec-how)
+		   (spec-how-old))
+		  ((null l))
+	       (setq spec-how (first l) spec-how-old (first l2))
+	       (setf (first l2)
+		     (if (eql-specializer-flag spec-how)
+			 (list* (eql-specializer-object spec-how)
+				(and (consp spec-how-old) spec-how-old))
+			 (if (consp spec-how-old)
+			     spec-how-old
+			     spec-how))))
+	     spec-how-list))
+      (let* ((spec-how-list nil)
+	     (function nil)
+	     (a-p-o (generic-function-argument-precedence-order gf)))
+	(dolist (method (generic-function-methods gf))
+	  (setf spec-how-list
+		(nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
+	(setf (generic-function-spec-list gf)
+	      (loop for type in spec-how-list
+		 for i from 0
+		 when type collect (cons type i)))
+	(let* ((g-f-l-l (generic-function-lambda-list gf)))
+	  (when (consp g-f-l-l)
+	    (let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
+	      (unless (equal a-p-o required-arguments)
+		(setf function
+		      (coerce `(lambda (%list)
+				 (destructuring-bind ,required-arguments %list
+				   (list ,@a-p-o)))
+			      'function))))))
+	(setf (generic-function-a-p-o-function gf) function)
+	(si:clear-gfun-hash gf)))))
 
 (defun print-object (object stream)
   (print-unreadable-object (object stream)))