/[cmucl]/src/pcl/combin.lisp
ViewVC logotype

Diff of /src/pcl/combin.lisp

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

revision 1.18 by gerd, Fri May 30 09:14:34 2003 UTC revision 1.19 by gerd, Mon Aug 25 20:10:41 2003 UTC
# Line 84  Line 84 
84    
85  (defun standard-compute-effective-method (gf combin applicable-methods)  (defun standard-compute-effective-method (gf combin applicable-methods)
86    (declare (ignore combin))    (declare (ignore combin))
87    (let ((before ())    (collect ((before) (primary) (after) (around) (invalid))
88          (primary ())      (labels ((lose (method why)
89          (after ())                 (invalid-method-error
90          (around ()))                  method
91      (flet ((lose (method why)                  "~@<The method ~S ~A.  ~
92               (invalid-method-error                   Standard method combination requires all methods to have ~
93                method                   one of the single qualifiers ~s, ~s and ~s or to have ~
94                "~@<The method ~S ~A.  ~                   no qualifier at all.~@:>"
95                 Standard method combination requires all methods to have one ~                  method why :around :before :after))
96                 of the single qualifiers ~s, ~s and ~s or to have no qualifier ~               (invalid-method (method why)
97                 at all.~@:>"                 (if *in-precompute-effective-methods-p*
98                method why :around :before :after)))                     (invalid method)
99                       (lose method why))))
100        (dolist (m applicable-methods)        (dolist (m applicable-methods)
101          (let ((qualifiers (if (listp m)          (let ((qualifiers (if (listp m)
102                                (early-method-qualifiers m)                                (early-method-qualifiers m)
103                                (method-qualifiers m))))                                (method-qualifiers m))))
104            (cond ((null qualifiers)            (cond ((null qualifiers)
105                   (push m primary))                   (primary m))
106                  ((cdr qualifiers)                  ((cdr qualifiers)
107                   (lose m "has more than one qualifier"))                   (invalid-method m "has more than one qualifier"))
108                  ((eq (car qualifiers) :around)                  ((eq (car qualifiers) :around)
109                   (push m around))                   (around m))
110                  ((eq (car qualifiers) :before)                  ((eq (car qualifiers) :before)
111                   (push m before))                   (before m))
112                  ((eq (car qualifiers) :after)                  ((eq (car qualifiers) :after)
113                   (push m after))                   (after m))
114                  (t                  (t
115                   (lose m "has an illegal qualifier"))))))                   (invalid-method m "has an invalid qualifier")))))
116      (setq before  (reverse before)        (cond ((invalid)
117            after   (reverse after)               `(%invalid-qualifiers ',gf ',combin .args. ',(invalid)))
118            primary (reverse primary)              ((null (primary))
119            around  (reverse around))               `(%no-primary-method ',gf .args.))
120      (cond ((null primary)              ((and (null (before)) (null (after)) (null (around)))
121             `(%no-primary-method ',gf .args.))               ;;
122            ((and (null before) (null after) (null around))               ;; By returning a single CALL-METHOD form here, we enable
123             ;;               ;; an important implementation-specific optimization, which
124             ;; By returning a single CALL-METHOD form here, we enable               ;; uses fast-method functions directly for effective method
125             ;; an important implementation-specific optimization, which               ;; functions.  (Which is also the reason emfs have a
126             ;; uses fast-method functions directly for effective method               ;; lambda-list like fast method functionts.)
127             ;; functions.  (Which is also the reason emfs have a               ;;
128             ;; lambda-list like fast method functionts.)               ;; This cannot be done if the gf requires keyword argument
129             ;;               ;; checking as in CLHS 7.6.5 because we can't tell in
130             ;; This cannot be done if the gf requires keyword argument               ;; method functions if they are used as emfs only.  If they
131             ;; checking as in CLHS 7.6.5 because we can't tell in               ;; are not used as emfs only, they should accept any keyword
132             ;; method functions if they are used as emfs only.  If they               ;; argumests, per CLHS 7.6.4, for instance.
133             ;; are not used as emfs only, they should accept any keyword               (let ((call-method `(call-method ,(first (primary))
134             ;; argumests, per CLHS 7.6.4, for instance.                                                ,(rest (primary)))))
135             (let ((call-method `(call-method ,(first primary) ,(rest primary))))                 (if (emfs-must-check-applicable-keywords-p gf)
136               (if (emfs-must-check-applicable-keywords-p gf)                     `(progn ,call-method)
137                   `(progn ,call-method)                     call-method)))
138                   call-method)))              (t
139            (t               (let ((main-effective-method
140             (let ((main-effective-method                      (if (or (before) (after))
141                     (if (or before after)                          `(multiple-value-prog1
142                         `(multiple-value-prog1                               (progn
143                            (progn                                 ,(make-call-methods (before))
144                              ,(make-call-methods before)                                 (call-method ,(first (primary)) ,(rest (primary))))
145                              (call-method ,(first primary) ,(rest primary)))                             ,(make-call-methods (reverse (after))))
146                            ,(make-call-methods (reverse after)))                          `(call-method ,(first (primary)) ,(rest (primary))))))
147                         `(call-method ,(first primary) ,(rest primary)))))                 (if (around)
148               (if around                     `(call-method ,(first (around))
149                   `(call-method ,(first around)                                   (,@(rest (around))
150                                 (,@(rest around)                                      (make-method ,main-effective-method)))
151                                    (make-method ,main-effective-method)))                     main-effective-method)))))))
                  main-effective-method))))))  
152    
153  (defvar *invalid-method-error*  (defvar *invalid-method-error*
154          (lambda (&rest args)          (lambda (&rest args)
# Line 438  Line 438 
438            (check-applicable-keywords            (check-applicable-keywords
439             (when (and applyp (emfs-must-check-applicable-keywords-p gf))             (when (and applyp (emfs-must-check-applicable-keywords-p gf))
440               '((check-applicable-keywords))))               '((check-applicable-keywords))))
441            (error-p (eq (first body) '%no-primary-method))            (error-p
442               (memq (first body) '(%no-primary-method %invalid-qualifiers)))
443            (mc-args-p            (mc-args-p
444             (when (eq *boot-state* 'complete)             (when (eq *boot-state* 'complete)
445               ;; Otherwise the METHOD-COMBINATION slot is not bound.               ;; Otherwise the METHOD-COMBINATION slot is not bound.

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19

  ViewVC Help
Powered by ViewVC 1.1.5