From 24ef6882fb811a77cc24df62db089a3840c0f1b2 Mon Sep 17 00:00:00 2001
From: pmai <pmai>
Date: Fri, 3 Jan 2003 18:50:24 +0000
Subject: [PATCH] Entomotomy Bug: define-method-combination-arguments-broken

Updated the fix for the broken handling of the :arguments option to
define-method-combination to Gerd Moellmann's latest patch.  Also
includes various indentation fixes and a smallish documentation/comment fix.
---
 pcl/combin.lisp            |  36 ++++++--
 pcl/defcombin.lisp         | 183 ++++++++++++++++---------------------
 pcl/defs.lisp              |  11 ++-
 pcl/generic-functions.lisp |   5 +-
 pcl/methods.lisp           |   3 +-
 5 files changed, 121 insertions(+), 117 deletions(-)

diff --git a/pcl/combin.lisp b/pcl/combin.lisp
index 5e57beb30..2c11eb50f 100644
--- a/pcl/combin.lisp
+++ b/pcl/combin.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.12 2002/12/18 19:16:28 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.13 2003/01/03 18:50:23 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -182,15 +182,30 @@
 	;; which we define here to collect all gf arguments, to pass
 	;; those together with the GF to no-primary-method:
 	((eq (first effective-method) '%no-primary-method)
-	  `(lambda (.pv-cell. .next-method-call. &rest .args.)
-	     (declare (ignore .pv-cell. .next-method-call.))
-	     (flet ((%no-primary-method (gf)
-	              (apply #'no-primary-method gf .args.)))
-	       ,effective-method)))
+	 `(lambda (.pv-cell. .next-method-call. &rest .args.)
+	    (declare (ignore .pv-cell. .next-method-call.))
+	    (flet ((%no-primary-method (gf)
+		     (apply #'no-primary-method gf .args.)))
+	      ,effective-method)))
+	;; When the method combination uses the :arguments option
+	((and (eq *boot-state* 'complete)
+	      ;; Otherwise the METHOD-COMBINATION slot is not bound.
+	      (let ((combin (generic-function-method-combination gf)))
+		(and (long-method-combination-p combin)
+		     (long-method-combination-arguments-lambda-list combin))))
+	 (let* ((required (dfun-arg-symbol-list metatypes))
+		(gf-args (if applyp
+			     `(list* ,@required .dfun-rest-arg.)
+			     `(list ,@required))))
+	   `(lambda ,ll
+	      (declare (ignore .pv-cell. .next-method-call.))
+	      (let ((.gf-args. ,gf-args))
+		(declare (ignorable .gf-args.))
+		,effective-method))))
 	(t
-	  `(lambda ,ll
-	     (declare (ignore .pv-cell. .next-method-call.))
-	     ,effective-method))))))
+	 `(lambda ,ll
+	    (declare (ignore .pv-cell. .next-method-call.))
+	    ,effective-method))))))
 
 (defun expand-emf-call-method (gf form metatypes applyp env)
   (declare (ignore gf metatypes applyp env))
@@ -313,7 +328,8 @@
   `(call-method-list
     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
 
-(defun standard-compute-effective-method (generic-function combin applicable-methods)
+(defun standard-compute-effective-method
+    (generic-function combin applicable-methods)
   (declare (ignore combin))
   (let ((before ())
 	(primary ())
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
index 5c7857308..22fdecfe5 100644
--- a/pcl/defcombin.lisp
+++ b/pcl/defcombin.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.19 2003/01/02 13:11:57 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.20 2003/01/03 18:50:23 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -219,17 +219,6 @@
 ;;;
 ;;;
 
-(defvar *combined-method-args*)
-(defvar *generic-function*)
-
-(defclass long-method-combination (standard-method-combination)
-  ((function
-    :initarg :function
-    :reader long-method-combination-function)
-   (arguments-lambda-list
-    :initarg :arguments-lambda-list
-    :reader long-method-combination-arguments-lambda-list)))
-
 (defun expand-long-defcombin (form)
   (let ((type (cadr form))
 	(lambda-list (caddr form))
@@ -284,23 +273,6 @@
     (add-method #'find-method-combination new-method)
     type))
 
-(defmethod compute-discriminating-function :around
-    ((gf standard-generic-function))
-  (let ((dfun (call-next-method)))
-    (if (let ((combin (generic-function-method-combination gf)))
-          (and (typep combin 'long-method-combination)
-               (long-method-combination-arguments-lambda-list combin)))
-        #'(kernel:instance-lambda (&rest args)
-            (let ((old (kernel:funcallable-instance-function gf))
-                  (*combined-method-args* args)
-                  (*generic-function* gf))
-              (unwind-protect
-                   (progn
-                     (set-funcallable-instance-function gf dfun)
-                     (apply gf args))
-                (set-funcallable-instance-function gf old))))
-        dfun)))
-
 (defmethod compute-effective-method ((generic-function generic-function)
 				     (combin long-method-combination)
 				     applicable-methods)
@@ -314,23 +286,22 @@
 ;;;
 ;;;
 (defun make-long-method-combination-function
-       (type ll method-group-specifiers arguments-option gf-var body)
-  ;;(declare (values documentation function))
+    (type ll method-group-specifiers arguments-option gf-var body)
   (declare (ignore type))
   (multiple-value-bind (real-body declarations documentation)
       ;; Note that PARSE-BODY ignores its second arg ENVIRONMENT.
       (system:parse-body body nil)
 
     (let ((wrapped-body
-	    (wrap-method-group-specifier-bindings method-group-specifiers
-						  declarations
-						  real-body)))
+	   (wrap-method-group-specifier-bindings method-group-specifiers
+						 declarations
+						 real-body)))
       (when gf-var
 	(push `(,gf-var .generic-function.) (cadr wrapped-body)))
       
       (when arguments-option
-	(setq wrapped-body (deal-with-arguments-option wrapped-body
-						       arguments-option)))
+	(setq wrapped-body
+	      (deal-with-arguments-option wrapped-body arguments-option)))
 
       (when ll
 	(setq wrapped-body
@@ -338,10 +309,11 @@
 		      (method-combination-options .method-combination.))))
 
       (values
-	documentation
-	`(lambda (.generic-function. .method-combination. .applicable-methods.)
-	   (progn .generic-function. .method-combination. .applicable-methods.)
-	   (block .long-method-combination-function. ,wrapped-body))))))
+       documentation
+       `(lambda (.generic-function. .method-combination. .applicable-methods.)
+	   (declare (ignorable .generic-function. .method-combination.
+		               .applicable-methods.))
+	  (block .long-method-combination-function. ,wrapped-body))))))
 ;;
 ;; parse-method-group-specifiers parse the method-group-specifiers
 ;;
@@ -448,33 +420,34 @@
 
 
 ;;;
-;;; This baby is a complete mess.  I can't believe we put it in this
-;;; way.  No doubt this is a large part of what drives MLY crazy.
-;;;
-;;; At runtime (when the effective-method is run), we bind an intercept
-;;; lambda-list to the arguments to the generic function.
-;;; 
-;;; At compute-effective-method time, the symbols in the :arguments
-;;; option are bound to the symbols in the intercept lambda list.
+;;; Return a form that deals with the :ARGUMENTS lambda-list of a long
+;;; method combination.  WRAPPED-BODY is the body of the method
+;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments
+;;; lambda-list of the method combination.
 ;;;
-(defun deal-with-arguments-option (wrapped-body args-lambda-list)
+(defun deal-with-arguments-option (wrapped-body arguments-lambda-list)
   (let ((intercept-rebindings
-	 (loop for arg in args-lambda-list
+	 (loop for arg in arguments-lambda-list
 	       unless (memq arg lambda-list-keywords)
 	       collect `(,arg ',arg)))
         (nreq 0)
         (nopt 0)
 	whole)
+    ;;
+    ;; Count the number of required and optional parameters in
+    ;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
+    ;; name of a &WHOLE parameter, if any.
     (loop with state = 'required
-          for arg in args-lambda-list do
+          for arg in arguments-lambda-list do
             (if (memq arg lambda-list-keywords)
                 (setq state arg)
                 (case state
                   (required (incf nreq))
                   (&optional (incf nopt))
-                  (&whole (setq whole arg)))))
+                  (&whole (setq whole arg
+				state 'required)))))
     ;;
-    ;; This assumes that the cadr of the WRAPPED-BODY is a let, and it
+    ;; This assumes that the WRAPPED-BODY is a let/let* form, and it
     ;; injects let-bindings of the form (ARG 'SYM) for all variables
     ;; of the argument-lambda-list; SYM is a gensym.
     (assert (memq (first wrapped-body) '(let let*)))
@@ -483,72 +456,74 @@
     ;;
     ;; Be sure to fill out the args lambda list so that it can be too
     ;; short if it wants to.
-    (unless (or (memq '&rest args-lambda-list)
-                (memq '&allow-other-keys args-lambda-list))
-      (let ((aux (memq '&aux args-lambda-list)))
-        (setq args-lambda-list
-              (append (ldiff args-lambda-list aux)
-                      (if (memq '&key args-lambda-list)
+    (unless (or (memq '&rest arguments-lambda-list)
+                (memq '&allow-other-keys arguments-lambda-list))
+      (let ((aux (memq '&aux arguments-lambda-list)))
+        (setq arguments-lambda-list
+              (append (ldiff arguments-lambda-list aux)
+                      (if (memq '&key arguments-lambda-list)
                           '(&allow-other-keys)
                           '(&rest .ignore.))
                       aux))))
-
     ;;
-    ;; the DESTRUCTURING-BIND binds the parameters of the
-    ;; ARGS-LAMBDA-LIST to actual generic function arguments.
-    ;; *COMBINEND-METHOD-ARGS* is bound to the generic function
-    ;; arguments by the discriminating functions created for generic
-    ;; functions having a method combination that uses :ARGUMENTS.
+    ;; .GENERIC-FUNCTION. is bound to the generic function in the
+    ;; method combination function, and .GF-ARGS* is bound to the
+    ;; generic function arguments in effective method functions
+    ;; created for generic functions having a method combination that
+    ;; uses :ARGUMENTS.
+    ;;
+    ;; The DESTRUCTURING-BIND binds the parameters of the
+    ;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments.
+    ;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the
+    ;; generic function's lambda list, which is only known at run time,
+    ;; this destructuring has to be done on a slighly modified list of
+    ;; actual arguments, from which values might be stripped or added.
     ;;
     ;; Using one of the variable names in the body inserts a symbol
     ;; into the effective method, and running the effective method
     ;; produces the value of actual argument that is bound to the
     ;; symbol.
-    `(let ((inner-result. ,wrapped-body))
-       `(destructuring-bind ,',args-lambda-list
-            (frob-args *combined-method-args*
-                       (generic-function-lambda-list *generic-function*)
-                       ,',nreq ,',nopt)
-          ,,(when (memq '.ignore. args-lambda-list)
-              ''(declare (ignore .ignore.)))
-          ;; If there is a &WHOLE in the args-lambda-list, let
-          ;; it result in the actual arguments of the generic-function
-          ;; not the frobbed list.
-          ,,(when whole
-              ``(setq ,',whole *combined-method-args*))
-          ,inner-result.))))
+    `(let ((inner-result. ,wrapped-body)
+           (gf-lambda-list (generic-function-lambda-list .generic-function.)))
+       `(destructuring-bind ,',arguments-lambda-list
+	    (frob-combined-method-args
+             .gf-args. ',gf-lambda-list
+             ,',nreq ,',nopt)
+	  ,,(when (memq '.ignore. arguments-lambda-list)
+	      ''(declare (ignore .ignore.)))
+	  ;; If there is a &WHOLE in the arguments-lambda-list, let
+	  ;; it result in the actual arguments of the generic-function
+	  ;; not the frobbed list.
+	  ,,(when whole
+	      ``(setq ,',whole .gf-args.))
+	  ,inner-result.))))
 
 ;;;
 ;;; Partition VALUES into three sections required, optional, and the
 ;;; rest, according to required, optional, and other parameters in
 ;;; LAMBDA-LIST.  Make the required and optional sections NREQ and
 ;;; NOPT elements long by discarding values or adding NILs.  Value is
-;;; the concatenated list of required and optional sections, plus what
+;;; the concatenated list of required and optional sections, and what
 ;;; is left as rest from VALUES.
 ;;;
-(defun frob-args (values lambda-list nreq nopt)
+(defun frob-combined-method-args (values lambda-list nreq nopt)
   (loop with section = 'required
-        with required = () and optional = ()
-        with nr = 0 and no = 0
-        for arg in lambda-list do
-          (if (member arg lambda-list-keywords :test #'eq)
-              (unless (eq (setq section arg) '&optional)
-                (loop-finish))
-              (case section
-                (required
-                 (incf nr)
-                 (push (pop values) required))
-                (&optional
-                 (incf no)
-                 (push (pop values) optional))))
-        finally
-          (flet ((frob (list n to)
-                   (cond ((> n to)
-                          (butlast (nreverse list) (- n to)))
-                         ((< n to)
-                          (nconc (nreverse list) (make-list (- to n))))
-                         (t
-                          (nreverse list)))))
-            (return (append (frob required nr nreq)
-                            (frob optional no nopt)
-                            values)))))
+        for arg in lambda-list
+        if (memq arg lambda-list-keywords) do
+	  (setq section arg)
+          (unless (eq section '&optional)
+            (loop-finish))
+	else if (eq section 'required)
+	  count t into nr
+          and collect (pop values) into required
+	else if (eq section '&optional)
+	  count t into no
+          and collect (pop values) into optional
+	finally
+	  (flet ((frob (list n m)
+                   (cond ((> n m) (butlast list (- n m)))
+                         ((< n m) (nconc list (make-list (- m n))))
+                         (t list))))
+            (return (nconc (frob required nr nreq)
+                           (frob optional no nopt)
+                           values)))))
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 97a3d8dd5..7cc2eea01 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -740,6 +740,14 @@
       (options       :reader method-combination-options
 	             :initarg :options)))
 
+(defclass long-method-combination (standard-method-combination)
+  ((function
+    :initarg :function
+    :reader long-method-combination-function)
+   (arguments-lambda-list
+    :initarg :arguments-lambda-list
+    :reader long-method-combination-arguments-lambda-list)))
+
 (defparameter *early-class-predicates*
   '((specializer specializerp)
     (exact-class-specializer exact-class-specializer-p)
@@ -760,5 +768,6 @@
     (standard-boundp-method standard-boundp-method-p)
     (generic-function generic-function-p)
     (standard-generic-function standard-generic-function-p)
-    (method-combination method-combination-p)))
+    (method-combination method-combination-p)
+    (long-method-combination long-method-combination-p)))
 
diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp
index 5f7705c7c..74229192e 100644
--- a/pcl/generic-functions.lisp
+++ b/pcl/generic-functions.lisp
@@ -2,7 +2,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.16 2002/12/18 19:16:28 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/generic-functions.lisp,v 1.17 2003/01/03 18:50:23 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -51,6 +51,9 @@
 ;          (short-method-combination)
 ;          (t)
 
+(defgeneric long-method-combination-p (object))
+;          (long-method-combination)
+;          (t)
 (defgeneric slot-class-p (object))
 ;          (t)
 ;          (slot-class)
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index ca7d167df..8e54412ac 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -1,3 +1,4 @@
+
 ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
 ;;;
 ;;; *************************************************************************
@@ -26,7 +27,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.21 2002/12/22 14:09:51 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.22 2003/01/03 18:50:24 pmai Exp $")
 ;;;
 
 (in-package :pcl)
-- 
GitLab