/[gcl]/gcl/pcl/pcl_defcombin.lisp
ViewVC logotype

Diff of /gcl/pcl/pcl_defcombin.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Wed Feb 26 22:21:39 2003 UTC revision 1.2 by camm, Tue Oct 7 21:06:33 2003 UTC
# Line 38  Line 38 
38        (expand-long-defcombin form)        (expand-long-defcombin form)
39        (expand-short-defcombin form)))        (expand-short-defcombin form)))
40    
41    ;;;
42    ;;; Implementation of INVALID-METHOD-ERROR and METHOD-COMBINATION-ERROR
43    ;;;
44    ;;; See combin.lisp for rest of the implementation.  This method is
45    ;;; defined here because compute-effective-method is still a function
46    ;;; in combin.lisp.
47    ;;;
48    (defmethod compute-effective-method :around
49        ((generic-function generic-function)
50         (method-combination method-combination)
51         applicable-methods)
52      (declare (ignore applicable-methods))
53      (flet ((real-invalid-method-error (method format-string &rest args)
54               (declare (ignore method))
55               (apply #'error format-string args))
56             (real-method-combination-error (format-string &rest args)
57               (apply #'error format-string args)))
58        (let ((*invalid-method-error* #'real-invalid-method-error)
59              (*method-combination-error* #'real-method-combination-error))
60          (call-next-method))))
61    
62    
63  ;;;  ;;;
64  ;;; STANDARD method combination  ;;; STANDARD method combination
# Line 107  Line 128 
128              :qualifiers ()              :qualifiers ()
129              :specializers specializers              :specializers specializers
130              :lambda-list '(generic-function type options)              :lambda-list '(generic-function type options)
131              :function #'(lambda (gf type options)              :function #'(lambda (args nms &rest cm-args)
132                            (declare (ignore gf))                          (declare (ignore nms cm-args))
133                            (do-short-method-combination                          (apply
134                              type options operator ioa new-method doc))                           (lambda (gf type options)
135                               (declare (ignore gf))
136                               (do-short-method-combination
137                                   type options operator ioa new-method doc))
138                             args))
139              :definition-source `((define-method-combination ,type) ,truename)))              :definition-source `((define-method-combination ,type) ,truename)))
140      (when old-method      (when old-method
141        (remove-method #'find-method-combination old-method))        (remove-method #'find-method-combination old-method))
# Line 140  Line 165 
165    (let ((type (method-combination-type combin))    (let ((type (method-combination-type combin))
166          (operator (short-combination-operator combin))          (operator (short-combination-operator combin))
167          (ioa (short-combination-identity-with-one-argument combin))          (ioa (short-combination-identity-with-one-argument combin))
168            (order (car (method-combination-options combin)))
169          (around ())          (around ())
170          (primary ()))          (primary ()))
171      (dolist (m applicable-methods)      (dolist (m applicable-methods)
# Line 163  Line 189 
189                   (push m primary))                   (push m primary))
190                  (t                  (t
191                   (lose m "has an illegal qualifier"))))))                   (lose m "has an illegal qualifier"))))))
192      (setq around (nreverse around)      (setq around (nreverse around))
193            primary (nreverse primary))      (unless (eq order :most-specific-last)
194          (setq primary (nreverse primary)))
195      (let ((main-method      (let ((main-method
196              (if (and (null (cdr primary))              (if (and (null (cdr primary))
197                       (not (null ioa)))                       (not (null ioa)))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26