Re: method combinations

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 454-5900

> * james anderson <wnzrf.naqrefba@frgs.qr> [2003-10-12 10:45:50 +0200]:
>
> but it is not clear if a "patch" is the right approach

IMO, it's the only maintainable approach.
The appended patch should adapt CLISP framework for method
combinations, so it should make it easier for you to make your patch
directly applicable.

Could you please try to merge your method-combination.lisp into the
patched clos.lisp?

thanks!

-- 
Sam Steingold (http://www.podval.org/~sds) running w2k
<http://www.camera.org> <http://www.iris.org.il> <http://www.memri.org/>
<http://www.mideasttruth.com/> <http://www.honestreporting.com>
Modern man is the missing link between apes and human beings.

--- clos.lisp.~1.55.~	2003-09-17 17:06:48.737669800 -0400
+++ clos.lisp	2003-11-08 16:58:40.239587200 -0500
@@ -1797,6 +1797,7 @@
 ;; - the signature, a signature struct (see compiler.lisp)
 ;; - the argument-precedence-order, as list of numbers from 0 to reqanz-1,
 ;; - the list of all methods.
+;; - the method combination object of NIL for STANDARD
 
 ;; The compiler uses (at GENERIC-FLET, GENERIC-LABELS) and the evaluator
 ;; presupposes likewise, that a generic function does not change its
@@ -1826,6 +1827,11 @@
 (defun (setf gf-methods) (new gf)
   (setf (sys::%record-ref gf 5) new))
 
+(defun gf-method-combination (gf)
+  (sys::%record-ref gf 6))
+(defun (setf gf-method-combination) (new gf)
+  (setf (sys::%record-ref gf 6) new))
+
 ;; The dispatch-code for generic functions is formed with
 ;; `(%GENERIC-FUNCTION-LAMBDA ,@lambdabody)
 ;; - similar to `(FUNCTION (LAMBDA ,@lambdabody)) -.
@@ -1858,7 +1864,7 @@
   ;; can always signal a NO-APPLICABLE-METHOD error
   (defun %make-gf (name signature argorder methods)
     (sys::%make-closure name prototype-code
-                        (list nil signature argorder methods) '(t . t))))
+                        (list nil signature argorder methods nil) '(t . t))))
 
 #||
  (defun make-gf (name lambdabody signature argorder methods)
@@ -2444,7 +2450,6 @@
     ;; 2. Sort the applicable methods by precedence order:
     (setq methods (sort-applicable-methods methods req-args arg-order))
     ;; 3. Apply method combination:
-    ;; only the STANDARD method combination is implemented.
     ;; split up into individual method types.
     (multiple-value-bind
           (primary-methods before-methods after-methods around-methods)
@@ -2453,6 +2458,11 @@
         (return-from compute-effective-method
           (no-method-caller 'no-primary-method gf)))
       ;; combine methods into an "effective method":
+      (let ((mc (gf-method-combination gf)))
+        (when mc
+          (return-from compute-effective-method
+            (funcall (method-combination-expander mc) primary-methods
+                     before-methods after-methods around-methods))))
       (labels ((ef-1 (primary-methods before-methods after-methods
                                       around-methods)
                  (if (null around-methods)
@@ -2704,7 +2714,7 @@
 ;; funname: function name, symbol or (SETF symbol)
 ;; lambdalist: lambdalist of the generic function
 ;; options: (option*)
-;; --> signature, argorder, method-forms, docstring
+;; --> signature, argorder, method-forms, docstring, method combination
 (defun analyze-defgeneric (caller funname lambdalist options env)
   (unless (function-name-p funname)
     (error-of-type 'sys::source-program-error
@@ -2715,6 +2725,7 @@
       (analyze-defgeneric-lambdalist caller funname lambdalist)
     ;; process the options:
     (let ((method-forms '())
+          (method-combination nil) ; == 'STANDARD
           (argorders nil)
           (docstrings nil))
       (dolist (option options)
@@ -2748,11 +2759,9 @@
                caller funname ':documentation))
            (setq docstrings (rest option)))
           (:METHOD-COMBINATION
-           ;; the method combination is being ignored.
            (unless (equal (rest option) '(STANDARD))
-             (error-of-type 'sys::source-program-error
-               (TEXT "~S ~S: The only valid method combination is ~S : ~S")
-               caller funname 'standard option)))
+             (setq method-combination
+                   (method-combination-object (cadr option)))))
           (:GENERIC-FUNCTION-CLASS
            ;; the class of the generic function is being ignored.
            (unless (equal (rest option) '(STANDARD-GENERIC-FUNCTION))
@@ -2803,7 +2812,8 @@
                 ;; list of the method-forms
                 (nreverse method-forms)
                 ;; docstring or nil
-                (car docstrings))))))
+                (car docstrings)
+                method-combination)))))
 
 ;; parse the lambdalist:
 ;; lambdalist --> reqanz, req-vars, optanz, restp, keyp, keywords, allowp
@@ -2882,7 +2892,7 @@
 ;;; DEFGENERIC
 
 (defmacro defgeneric (funname lambda-list &rest options &environment env)
-  (multiple-value-bind (signature argorder method-forms docstring)
+  (multiple-value-bind (signature argorder method-forms docstring method-combo)
       (analyze-defgeneric 'defgeneric funname lambda-list options env)
     `(LET ()
        (COMPILER::EVAL-WHEN-COMPILE
@@ -2896,13 +2906,14 @@
                                         ',(second funname))))))
              `((SYSTEM::%SET-DOCUMENTATION ,symbolform 'FUNCTION
                                            ',docstring))))
-       (DO-DEFGENERIC ',funname ',signature ',argorder ,@method-forms))))
+       (DO-DEFGENERIC ',funname ',signature ',argorder ',method-combo
+                      ,@method-forms))))
 
 (defun ensure-generic-function (function-name &key argument-precedence-order
                                 declare documentation environment
                                 generic-function-class lambda-list
                                 method-class method-combination)
-  (multiple-value-bind (signature argorder)
+  (multiple-value-bind (signature argorder method-forms doc method-combo)
       (analyze-defgeneric
        'defgeneric function-name lambda-list
        `(,@(if declare `(:declare ,declare))
@@ -2917,15 +2928,18 @@
          ,@(if method-combination `(:method-combination ,method-combination))
          ,@(if method-class `(:method-class ,method-class)))
        environment)
-    (do-defgeneric function-name signature argorder)))
+    (declare (ignore method-forms doc))
+    (do-defgeneric function-name signature argorder method-combo)))
 
-(defun make-generic-function (funname signature argorder &rest methods)
+(defun make-generic-function (funname signature argorder method-combo
+                              &rest methods)
   (let ((gf (make-fast-gf funname signature argorder)))
     (dolist (method methods) (std-add-method gf method))
     (finalize-fast-gf gf)
+    (setf (gf-method-combination gf) method-combo)
     gf))
 
-(defun do-defgeneric (funname signature argorder &rest methods)
+(defun do-defgeneric (funname signature argorder method-combo &rest methods)
   (if (fboundp funname)
     (let ((gf (fdefinition funname)))
       (if (clos::generic-function-p gf)
@@ -2944,7 +2958,8 @@
           (TEXT "~S: ~S does not name a generic function")
           'defgeneric funname)))
     (setf (fdefinition funname)
-          (apply #'make-generic-function funname signature argorder methods))))
+          (apply #'make-generic-function funname signature argorder
+                 method-combo methods))))
 
 
 #||  ;; For GENERIC-FLET, GENERIC-LABELS
@@ -2961,10 +2976,11 @@
 ;; For GENERIC-FUNCTION, GENERIC-FLET, GENERIC-LABELS
 
 (defun make-generic-function-form (caller funname lambda-list options env)
-  (multiple-value-bind (signature argorder method-forms docstring)
+  (multiple-value-bind (signature argorder method-forms docstring method-combo)
       (analyze-defgeneric caller funname lambda-list options env)
     (declare (ignore docstring))
-    `(MAKE-GENERIC-FUNCTION ',funname ',signature ',argorder ,@method-forms)))
+    `(MAKE-GENERIC-FUNCTION ',funname ',signature ',argorder ',method-combo
+                            ,@method-forms)))
 
 #| GENERIC-FUNCTION is a TYPE (and a COMMON-LISP symbol) in ANSI CL,
  but not a macro, so this definition violates the standard
@@ -3731,6 +3747,38 @@
   (:method ((class standard-class)) (class-finalize class t))
   (:method ((name symbol)) (finalize-inheritance (find-class name))))
 
+;;; method combinations
+(defvar *method-combination-arguments* nil
+  "the actual generic function call arguments (in compute-effective-method)" )
+(defvar *method-combination-generic-function* nil
+  "the generic function applied (in compute-effective-method)")
+(defvar *method-combination* nil
+  "the generic function's method combination (in compute-effective-method)")
+
+(defun method-combination-object (name &key (if-does-not-exist :error))
+  (or (get name 'method-combination-object)
+      (and if-does-not-exist
+           (error "undefined method combination ~s" name))))
+(defun (setf method-combination-object) (def name)
+  (setf (get name 'method-combination-object) def))
+
+(defclass method-combination ()
+  ((name :initarg :name :reader method-combination-name)
+   (identity-with-one-argument :initarg :identity-with-one-argument
+                               :initform nil
+                               :reader method-combination-id1-p)
+   (documentation :initarg :documentation
+                  :accessor method-combination-documentation)
+   ;; function of 4 arguments which combines methods into the effective method
+   (expander :initarg :expander :reader method-combination-expander)))
+
+;(setf (method-combination-object 'standard) ; never used
+;      (make-instance 'method-combination :name 'standard
+;                     :documentation "the STANDARD method combination object"
+;                     :expander #'standard-method-combination-expander))
+
+;; (defmacro define-method-combination (name ...) ....)
+
 ;;; Utility functions
 
 ;; Returns the slot names of an instance of a slotted-class
@@ -3763,8 +3811,12 @@
   (:method ((x symbol) (doc-type (eql 'class))) ; class --> type
     (declare (ignore doc-type))
     (documentation x 'type))
-  ;;(:method ((x method-combination) (doc-type (eql 't))))
-  ;;(:method ((x method-combination) (doc-type (eql 'method-combination))))
+  (:method ((x method-combination) (doc-type (eql 't)))
+    (declare (ignore doc-type))
+    (method-combination-documentation x))
+  (:method ((x method-combination) (doc-type (eql 'method-combination)))
+    (declare (ignore doc-type))
+    (method-combination-documentation x))
   (:method ((x standard-method) (doc-type (eql 't)))
     (declare (ignore doc-type))
     (getf (gethash x sys::*documentation*) 'standard-method))
@@ -3824,8 +3876,13 @@
   (:method (new-value (x symbol) (doc-type (eql 'class)))
     (declare (ignore doc-type))
     (sys::%set-documentation x 'type new-value))
-  ;;(:method (new-value (x method-combination) (doc-type (eql 't))))
-  ;;(:method (new-value (x method-combination) (doc-type (eql 'method-combination))))
+  (:method (new-value (x method-combination) (doc-type (eql 't)))
+    (declare (ignore doc-type))
+    (setf (method-combination-documentation x) new-value))
+  (:method (new-value (x method-combination)
+            (doc-type (eql 'method-combination)))
+    (declare (ignore doc-type))
+    (setf (method-combination-documentation x) new-value))
   (:method (new-value (x standard-method) (doc-type (eql 't)))
     (declare (ignore doc-type))
     (sys::%set-documentation x 'standard-method new-value))



