source: trunk/source/lib/method-combination.lisp @ 11347

Last change on this file since 11347 was 11347, checked in by gb, 11 years ago

In %DEFINE-METHOD-COMBINATION-EVALUATOR, don't treat (MCI.OPTIONS MCI)
as a property list unless (MCI.CLASS MCI) is SHORT-METHOD-COMBINATION
(ticket:377).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.4 KB
Line 
1; -*- Mode:Lisp; Package:CCL; -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;;;;;;;;;;;;;;;
19;;
20;; define-method-combination.lisp
21;; Copyright 1990-1994, Apple Computer, Inc.
22;; Copyright 1995-1996 Digitool, Inc.
23
24;;
25
26;;;;;;;;;;;;;;;
27;
28; Change History
29;
30; 05/31/96 bill list method combination is not :identity-with-one-argument
31; ------------- MCL-PPC 3.9
32; 12/01/93 bill specifier-match-p uses EQUAL instead of EQ
33; ------------- 3.0d13
34; 04/30/93 bill no-applicable-primary-method -> make-no-applicable-method-function
35; ------------  2.0
36; 11/05/91 gb   experiment with INLINE.
37; 09/26/91 bill %badarg had the wrong number of args in with-call-method-context.
38;               Mix in Flavors Technology's optimization.
39; 07/21/91 gb   Use DYNAMIC-EXTENT vice DOWNWARD-FUNCTION.
40; 06/26/91 bill method-combination's direct-superclass is metaobject
41;-------------- 2.0b2
42; 02/13/91 bill New File.
43;------------ 2.0b1
44;
45
46; MOP functions pertaining to method-combination:
47;
48; COMPUTE-DISCRIMINATING-FUNCTION generic-function (not implemented)
49; COMPUTE-EFFECTIVE-METHOD generic-function method-combination methods
50; FIND-METHOD-COMBINATION generic-function method-combination-type method-combination-options
51; Readers for method-combination objects
52; METHOD-COMBINATION-NAME
53; METHOD-COMBINATION-OPTIONS
54; METHOD-COMBINATION-ORDER
55; METHOD-COMBINATION-OPERATOR
56; METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT
57
58(in-package "CCL")
59
60(defclass method-combination (metaobject)
61  ((name :reader method-combination-name :initarg :name)
62   (options :reader method-combination-options :initarg :options :initform nil)))
63
64(defclass short-method-combination (method-combination) 
65  ((operator :reader method-combination-operator :initarg :operator :initform nil)
66   (identity-with-one-argument :reader method-combination-identity-with-one-argument
67                               :initarg :identity-with-one-argument
68                               :initform nil))
69  (:documentation "Generated by the simple form of define-method-combination"))
70
71(defclass long-method-combination (method-combination)
72  ((expander :reader method-combination-expander :initarg :expander
73             :documentation "The expander is called by compute-effective-method with args: gf mc options methods args")
74   )
75  (:documentation "Generated by the long form of define-method-combination"))
76
77(defmethod print-object ((object method-combination) stream)
78  (print-unreadable-object (object stream :type t)
79    (let* ((name (method-combination-name object))
80           (options (method-combination-options object)))
81      (declare (dynamic-extent options))
82      (prin1 name stream)
83      (dolist (option options)
84        (pp-space stream)
85        (prin1 option stream)))))
86
87; Hash a method-combination name to a method-combination-info vector
88(defvar *method-combination-info* (make-hash-table :test 'eq))
89
90(defmacro method-combination-info (method-combination-type)
91  `(gethash ,method-combination-type *method-combination-info*))
92
93;;; Need to special case (find-method-combination #'find-method-combination ...)
94(without-duplicate-definition-warnings ;; override version in l1-clos-boot.lisp
95 (defmethod find-method-combination ((generic-function standard-generic-function)
96                                     method-combination-type
97                                     method-combination-options)
98   (%find-method-combination
99    generic-function method-combination-type method-combination-options)))
100
101(defun %find-method-combination (gf type options)
102  (declare (ignore gf))
103  (if (eq type 'standard)
104    (progn
105      (unless (null options)
106        (error "STANDARD method-combination accepts no options."))
107      *standard-method-combination*)
108    (let ((mci (method-combination-info type)))
109      (unless mci
110        (error "~s is not a method-combination type" type))
111      (labels ((same-options-p (o1 o2)
112                 (cond ((null o1) (null o2))
113                       ((null o2) nil)
114                       ((or (atom o1) (atom o2)) nil)
115                       ((eq (car o1) (car o2)) 
116                        (same-options-p (cdr o1) (cdr o2)))
117                       (t nil))))
118        (dolist (mc (population-data (mci.instances mci)))
119          (when (same-options-p options (method-combination-options mc))
120            (return-from %find-method-combination mc))))
121      (let ((new-mc 
122             (case (mci.class mci)
123               (short-method-combination
124                (unless (or (null options)
125                            (and (listp options)
126                                 (null (cdr options))
127                                 (memq (car options)
128                                       '(:most-specific-first :most-specific-last))))
129                  (error "Illegal method-combination options: ~s" options))
130                (destructuring-bind (&key identity-with-one-argument
131                                          (operator type)
132                                          &allow-other-keys)
133                                    (mci.options mci)
134                  (make-instance 'short-method-combination
135                                 :name type
136                                 :identity-with-one-argument identity-with-one-argument
137                                 :operator operator
138                                 :options options)))
139               (long-method-combination
140                (make-instance 'long-method-combination
141                               :name type
142                               :options options
143                               :expander (mci.options mci)))
144               (t (error "Don't understand ~s method-combination" type)))))
145        (push new-mc (population-data (mci.instances mci)))
146        new-mc))))
147   
148; Push GF on the MCI.GFS population of its method-combination type.
149(defun register-gf-method-combination (gf &optional (mc (%gf-method-combination gf)))
150  (unless (eq mc *standard-method-combination*)
151    (let* ((name (method-combination-name mc))
152           (mci (or (method-combination-info name)
153                    (error "~s not a known method-combination type" name)))
154           (gfs (mci.gfs mci)))
155      (pushnew gf (population-data gfs)))
156    mc))
157
158(defun unregister-gf-method-combination (gf &optional (mc (%gf-method-combination gf)))
159  (unless (eq mc *standard-method-combination*)
160    (let* ((name (method-combination-name mc))
161           (mci (or (method-combination-info name)
162                    (error "~s not a known method-combination type" name)))
163           (gfs (mci.gfs mci)))
164      (setf (population-data gfs) (delq gf (population-data gfs))))
165    mc))
166
167
168;;; Need to special case (compute-effective-method #'compute-effective-method ...)
169(defmethod compute-effective-method ((generic-function standard-generic-function)
170                                     (method-combination standard-method-combination)
171                                     methods)
172  (%compute-standard-effective-method generic-function method-combination methods))
173
174(defun %compute-standard-effective-method (generic-function method-combination methods)
175  (declare (ignore method-combination))
176  (make-standard-combined-method methods nil generic-function t))
177
178(defvar *method-combination-evaluators* (make-hash-table :test 'eq))
179
180(defmacro get-method-combination-evaluator (key)
181  `(gethash ,key *method-combination-evaluators*))
182
183(defmacro define-method-combination-evaluator (name arglist &body body)
184  (setq name (require-type name 'symbol))
185  (unless (and arglist (listp arglist) (eq (length arglist) 2))
186    (error "A method-combination-evaluator must take two args."))
187  `(%define-method-combination-evaluator ',name #'(lambda ,arglist ,@body)))
188
189(defun %define-method-combination-evaluator (operator function)
190  (setq operator (require-type operator 'symbol))
191  (setq function (require-type function 'function))
192  (record-source-file operator 'method-combination-evaluator)
193  (setf (get-method-combination-evaluator operator) function)
194  (maphash #'(lambda (name mci)
195               (when (eq operator (or (and (eq (mci.class mci) 'short-method-combination) (getf (mci.options mci) :operator)) name)))
196                 (clear-method-combination-caches name mci))
197           *method-combination-info*)
198  function)
199
200(defmethod compute-effective-method ((generic-function standard-generic-function)
201                                     (method-combination short-method-combination)
202                                     methods)
203  (or (get-combined-method methods generic-function)
204      (put-combined-method
205       methods
206       (let* ((arounds nil)
207              (primaries nil)
208              (iwoa (method-combination-identity-with-one-argument method-combination))
209              (reverse-p (eq (car (method-combination-options method-combination))
210                             :most-specific-last))
211              (operator (method-combination-operator method-combination))
212              (name (method-combination-name method-combination))
213              qualifiers
214              q)
215         (dolist (m methods)
216           (setq qualifiers (method-qualifiers m))
217           (unless (and qualifiers (null (cdr qualifiers))
218                        (cond ((eq (setq q (car qualifiers)) name)
219                               (push m primaries))
220                              ((eq q :around)
221                               (push m arounds))
222                              (t nil)))
223             (%invalid-method-error m "invalid method qualifiers: ~s" qualifiers)))
224         (when (null primaries)
225           (return-from compute-effective-method
226             (make-no-applicable-method-function generic-function)))
227         (setq arounds (nreverse arounds))
228         (unless reverse-p (setq primaries (nreverse primaries)))
229         (or (optimized-short-effective-method generic-function operator iwoa arounds primaries)
230             (let ((code (if (and iwoa (null (cdr primaries)))
231                           `(call-method ,(car primaries) nil)
232                           `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m nil)) primaries)))))
233               (make-effective-method
234                generic-function
235                (if arounds
236                  `(call-method ,(car arounds)
237                                (,@(cdr arounds) (make-method ,code)))
238                  code)))))
239       generic-function)))
240
241(defun optimized-short-effective-method (gf operator iwoa arounds primaries)
242  (let* ((functionp (functionp (fboundp operator)))
243         (evaluator (unless functionp (get-method-combination-evaluator operator))))
244    (when (or functionp evaluator)
245      (let ((code (if (and iwoa (null (cdr primaries)))
246                    (let ((method (car primaries)))
247                      (if (call-next-method-p method)
248                        #'(lambda (&rest args)
249                            (declare (dynamic-extent args))
250                            (%%call-method* method nil args))
251                        (method-function method)))
252                    (if functionp
253                      (let ((length (length primaries))
254                            (primaries primaries))
255                        #'(lambda (&rest args)
256                            (declare (dynamic-extent args))
257                            (let* ((results (make-list length))
258                                   (results-tail results))
259                              (declare (cons results-tail))
260                              (declare (dynamic-extent results))
261                              (dolist (method primaries)
262                                (setf (car results-tail)
263                                      (%%call-method* method nil args))
264                                (pop results-tail))
265                              (apply operator results))))
266                      (let ((primaries primaries))
267                        #'(lambda (&rest args)
268                            (declare (dynamic-extent args))
269                            (funcall evaluator primaries args)))))))
270        (if arounds
271          (let* ((code-method (make-instance 'standard-method
272                                             :function code
273                                             :generic-function gf
274                                             :name (function-name gf)))
275                 (first-around (car arounds))
276                 (rest-arounds (nconc (cdr arounds) (list code-method))))
277            #'(lambda (&rest args)
278                (declare (dynamic-extent args))
279                (%%call-method* first-around rest-arounds args)))
280          code)))))
281
282(defmethod compute-effective-method ((generic-function standard-generic-function)
283                                     (method-combination long-method-combination)
284                                     methods)
285  (or (get-combined-method methods generic-function)
286      (destructuring-bind ((args-var . gf-name) . expander) 
287                          (method-combination-expander method-combination)
288        (let* ((user-form (funcall expander
289                                   generic-function
290                                   methods
291                                   (method-combination-options method-combination)))
292               (effective-method
293                (if (functionp user-form)
294                  user-form 
295                  (make-effective-method generic-function user-form args-var gf-name))))
296          (put-combined-method methods effective-method generic-function)))))
297
298(defmacro with-call-method-context (args-var &body body)
299  (labels ((bad-call-method-method (method)
300             (error "~s is neither a method nor a ~s form." method 'make-method))
301           (call-method-aux (method next-methods args-var)
302             (unless (typep method 'standard-method)
303               (if (and (listp method) (eq (car method) 'make-method))
304                 (setq method (%make-method method))
305                 (bad-call-method-method method)))
306             (let ((real-next-methods nil))
307               (dolist (m next-methods)
308                 (cond ((typep m 'standard-method)
309                        (push m real-next-methods))
310                       ((and (listp m) (eq (car m) 'make-method))
311                        (push (%make-method m) real-next-methods))
312                       (t (bad-call-method-method m))))
313               `(%%call-method* ,method
314                                ',(nreverse real-next-methods)
315                                ,args-var))))
316    `(macrolet ((call-method (method &optional next-methods)
317                  (funcall ',#'call-method-aux method next-methods ',args-var)))
318       ,@body)))
319
320(defun %make-method (make-method-form &optional
321                                      args-var
322                                      generic-function
323                                      (method-class 'standard-method))
324  (setq args-var (require-type args-var 'symbol))
325  (unless (and (cdr make-method-form) (null (cddr make-method-form)))
326    (%method-combination-error "MAKE-METHOD requires exactly one argument."))
327  (let ((form (cadr make-method-form)))
328    (make-instance 
329     method-class
330     :generic-function generic-function
331     :name (and (functionp generic-function) (function-name generic-function))
332     :function (%make-function
333                nil
334                `(lambda (&rest ,(setq args-var (or args-var (make-symbol "ARGS"))))
335                   (declare (ignore-if-unused ,args-var)
336                            (dynamic-extent ,args-var))
337                   (with-call-method-context ,args-var
338                     ,form))
339                nil))))
340
341(defmethod call-next-method-p ((method standard-method))
342  (call-next-method-p (%method-function method)))
343
344(defmethod call-next-method-p ((function function))
345  (let (lfbits)
346    (and (logbitp $lfbits-method-bit
347                  (setq lfbits (lfun-bits function)))
348         (logbitp $lfbits-nextmeth-bit lfbits))))
349
350(defun make-effective-method (gf form  &optional (args-sym (make-symbol "ARGS")) (gf-name (make-symbol "GF")))
351  (setq args-sym (require-type args-sym 'symbol))
352  (let (m mf)
353    (if (and (listp form)
354             (eq (car form) 'call-method)
355             (listp (cdr form))
356             (typep (setq m (cadr form)) 'standard-method)
357             (listp (cddr form))
358             (null (cdddr form))
359             (not (call-next-method-p (setq mf (%method-function m)))))
360      mf
361      (%make-function
362       nil
363       `(lambda (&rest ,args-sym)
364         (declare (dynamic-extent ,args-sym))
365         (let* ((,gf-name ,gf))
366           (declare (ignorable ,gf-name))
367           (with-call-method-context ,args-sym
368             ,form)))
369       nil))))
370
371;;;;;;;
372;;
373;; Expansions of the DEFINE-METHOD-COMBINATION macro
374;;
375
376;;
377;; Short form
378;;
379(defun short-form-define-method-combination (name options)
380  (destructuring-bind (&key documentation identity-with-one-argument
381                            (operator name)) options
382    (setq name (require-type name 'symbol)
383          operator (require-type operator 'symbol)
384          documentation (unless (null documentation)
385                          (require-type documentation 'string)))
386    (let* ((mci (method-combination-info name))
387           (was-short? (and mci (eq (mci.class mci) 'short-method-combination))))
388      (when (and mci (not was-short?))
389        (check-long-to-short-method-combination name mci))
390      (if mci
391        (let ((old-options (mci.options mci)))
392          (setf (mci.class mci) 'short-method-combination
393                (mci.options mci) options)
394          (unless (and was-short?
395                       (destructuring-bind (&key ((:identity-with-one-argument id))
396                                                 ((:operator op) name)
397                                                 &allow-other-keys)
398                                           old-options
399                         (and (eq id identity-with-one-argument)
400                              (eq op operator))))
401            (update-redefined-short-method-combinations name mci)))
402        (setf (method-combination-info name)
403              (setq mci (%cons-mci 'short-method-combination options)))))
404    (set-documentation name 'method-combination documentation))
405  (record-source-file name 'method-combination)
406  name)
407
408(defun check-long-to-short-method-combination (name mci)
409  (dolist (gf (population-data (mci.gfs mci)))
410    (let ((options (method-combination-options (%gf-method-combination gf))))
411      (unless (or (null options)
412                  (and (listp options)
413                       (null (cdr options))
414                       (memq (car options) '(:most-specific-first :most-specific-last))))
415        (error "Redefining ~s method-combination disagrees with the~
416                method-combination arguments to ~s" name gf)))))
417
418(defun update-redefined-short-method-combinations (name mci)
419  (destructuring-bind (&key identity-with-one-argument (operator name)  documentation)
420                      (mci.options mci)
421    (declare (ignore documentation))
422    (dolist (mc (population-data (mci.instances mci)))
423      (when (typep mc 'long-method-combination)
424        (change-class mc 'short-method-combination))
425      (if (typep mc 'short-method-combination)
426         (setf (slot-value mc 'identity-with-one-argument) identity-with-one-argument
427               (slot-value mc 'operator) operator)
428         (error "Bad method-combination-type: ~s" mc))))
429  (clear-method-combination-caches name mci))
430
431(defun clear-method-combination-caches (name mci)
432  (dolist (gf (population-data (mci.gfs mci)))
433    (clear-gf-cache gf))
434  (when *effective-method-gfs*          ; startup glitch
435    (let ((temp #'(lambda (mc gf)
436                    (when (eq name (method-combination-name (%gf-method-combination gf)))
437                      (remhash mc *effective-method-gfs*)
438                      (remhash mc *combined-methods*)))))
439      (declare (dynamic-extent temp))
440      (maphash temp *effective-method-gfs*))))
441
442;;; Support el-bizarro arglist partitioning for the long form of
443;;; DEFINE-METHOD-COMBINATION.
444(defun nth-required-gf-arg (gf argvals i)
445  (declare (fixnum i))
446  (let* ((bits (lfun-bits gf))
447         (numreq (ldb $lfbits-numreq bits)))
448    (declare (fixnum bits numreq))
449    (if (< i numreq)
450      (nth i argvals))))
451
452(defun nth-opt-gf-arg-present-p (gf argvals i)
453  (declare (fixnum i))
454  (let* ((bits (lfun-bits gf))
455         (numreq (ldb $lfbits-numreq bits))
456         (numopt (ldb $lfbits-numopt bits)))
457    (declare (fixnum bits numreq numopt))
458    (and (< i numopt)
459         (< (the fixum (+ i numreq)) (length argvals)))))
460
461;;; This assumes that we've checked for argument presence.
462(defun nth-opt-gf-arg (gf argvals i)
463  (declare (fixnum i))
464  (let* ((bits (lfun-bits gf))
465         (numreq (ldb $lfbits-numreq bits)))
466    (declare (fixnum bits numreq ))
467    (nth (the fixum (+ i numreq)) argvals)))
468
469(defun gf-arguments-tail (gf argvals)
470  (let* ((bits (lfun-bits gf))
471         (numreq (ldb $lfbits-numreq bits))
472         (numopt (ldb $lfbits-numopt bits)))
473    (declare (fixnum bits numreq numopt))
474    (nthcdr (the fixnum (+ numreq numopt)) argvals)))
475
476(defun gf-key-present-p (gf argvals key)
477  (let* ((tail (gf-arguments-tail gf argvals))
478         (missing (cons nil nil)))
479    (declare (dynamic-extent missing))
480    (not (eq missing (getf tail key missing)))))
481
482;; Again, this should only be called if GF-KEY-PRESENT-P returns true.
483(defun gf-key-value (gf argvals key)
484  (let* ((tail (gf-arguments-tail gf argvals)))
485    (getf tail key))) 
486 
487
488(defun lfmc-bindings (gf-form args-form lambda-list)
489  (let* ((req-idx 0)
490         (opt-idx 0)
491         (state :required))
492    (collect ((names)
493              (vals))
494      (dolist (arg lambda-list)
495        (case arg
496          ((&whole &optional &rest &key &allow-other-keys &aux)
497           (setq state arg))
498          (t
499           (case state
500             (:required
501              (names arg)
502              (vals (list 'quote `(nth-required-gf-arg ,gf-form ,args-form ,req-idx)))
503              (incf req-idx))
504             (&whole
505              (names arg)
506              (vals `,args-form)
507              (setq state :required))
508             (&optional
509              (let* ((var arg)
510                     (val nil)
511                     (spvar nil))
512                (when (listp arg)
513                  (setq var (pop arg)
514                        val (pop arg)
515                        spvar (car arg)))
516                (names var)
517                (vals (list 'quote
518                            `(if (nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx)
519                              (nth-opt-gf-arg ,gf-form ,args-form ,opt-idx)
520                              ,val)))
521                (when spvar
522                  (names spvar)
523                  (vals (list 'quote 
524                         `(nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx))))
525                (incf opt-idx)))
526             (&rest
527              (names arg)
528              (vals (list 'quote
529                          `(gf-arguments-tail ,gf-form ,args-form))))
530             (&key
531              (let* ((var arg)
532                     (keyword nil)
533                     (val nil)
534                     (spvar nil))
535                (if (atom arg)
536                  (setq keyword (make-symbol (symbol-name arg)))
537                  (progn
538                    (setq var (car arg))
539                    (if (atom var)
540                      (setq keyword (make-symbol (symbol-name var)))
541                      (setq keyword (car var) var (cadr var)))
542                    (setq val (cadr arg) spvar (caddr arg))))
543                (names var)
544                (vals (list 'quote `(if (gf-key-present-p ,gf-form ,args-form ',keyword)
545                                     (gf-key-value ,gf-form ,args-form ',keyword)
546                                     ,val)))
547                (when spvar
548                  (names spvar)
549                  (vals (list 'quote `(gf-key-present-p ,gf-form ,args-form ',keyword))))))
550             (&allow-other-keys)
551             (&aux
552              (cond ((atom arg)
553                     (names arg)
554                     (vals nil))
555                    (t
556                     (names (car arg))
557                     (vals (list 'quote (cadr arg))))))))))
558      (values (names) (vals)))))
559;;
560;; Long form
561;;
562(defun long-form-define-method-combination (name lambda-list method-group-specifiers
563                                                 forms env)
564  (let (arguments args-specified? generic-fn-symbol gf-symbol-specified?)
565    (unless (verify-lambda-list lambda-list)
566      (error "~s is not a proper lambda-list" lambda-list))
567    (loop
568      (unless (and forms (consp (car forms))) (return))
569      (case (caar forms)
570        (:arguments
571         (when args-specified? (error ":ARGUMENTS specified twice"))
572         (setq arguments (cdr (pop forms))
573               args-specified? t)
574         (do ((args arguments (cdr args)))
575             ((null args))
576           (setf (car args) (require-type (car args) 'symbol))))
577        (:generic-function
578         (when gf-symbol-specified? (error ":GENERIC-FUNCTION specified twice"))
579         (setq generic-fn-symbol
580               (require-type (cadr (pop forms)) '(and symbol (not null)))
581               gf-symbol-specified? t))
582        (t (return))))
583    (multiple-value-bind (body decls doc) (parse-body forms env)
584      (unless generic-fn-symbol (setq generic-fn-symbol (make-symbol "GF")))
585      (multiple-value-bind (specs order-forms required-flags descriptions)
586                           (parse-method-group-specifiers method-group-specifiers)
587        (let* ((methods-sym (make-symbol "METHODS"))
588               (args-sym (make-symbol "ARGS"))
589               (options-sym (make-symbol "OPTIONS"))
590               (arg-vars ())
591               (arg-vals ())
592               (code `(lambda (,generic-fn-symbol ,methods-sym ,options-sym)
593                        ,@(unless gf-symbol-specified?
594                            `((declare (ignore-if-unused ,generic-fn-symbol))))
595                        (let* (,@(progn
596                                  (multiple-value-setq (arg-vars arg-vals)
597                                    (lfmc-bindings generic-fn-symbol
598                                                   args-sym
599                                                   arguments))
600                                  (mapcar #'list arg-vars arg-vals)))
601                          (declare (ignorable ,@arg-vars))
602                          ,@decls
603                          (destructuring-bind ,lambda-list ,options-sym
604                            (destructuring-bind
605                              ,(mapcar #'car method-group-specifiers)
606                              (seperate-method-groups
607                               ,methods-sym ',specs
608                               (list ,@order-forms)
609                               ',required-flags
610                               ',descriptions)
611                              ,@body))))))
612          `(%long-form-define-method-combination
613            ',name (cons (cons ',args-sym ',generic-fn-symbol) #',code) ',doc))))))
614
615(defun %long-form-define-method-combination (name args-var.expander documentation)
616  (setq name (require-type name 'symbol))
617  (let* ((mci (method-combination-info name)))
618    (if mci
619      (progn
620        (setf (mci.class mci) 'long-method-combination
621              (mci.options mci) args-var.expander)
622        (update-redefined-long-method-combinations name mci))
623      (setf (method-combination-info name)
624            (setq mci (%cons-mci 'long-method-combination args-var.expander)))))
625  (set-documentation name 'method-combination documentation)
626  (record-source-file name 'method-combination)
627  name)
628
629(defun update-redefined-long-method-combinations (name mci)
630  (let ((args-var.expander (mci.options mci)))
631    (dolist (mc (population-data (mci.instances mci)))
632      (when (typep mc 'short-method-combination)
633        (change-class mc 'long-method-combination))
634      (if (typep mc 'long-method-combination)
635        (setf (slot-value mc 'expander) args-var.expander)
636        (error "Bad method-combination-type: ~s" mc))))
637  (clear-method-combination-caches name mci))
638
639; Returns four values:
640; method-group specifiers with :order, :required, & :description parsed out
641; Values for the :order args
642; Values for the :required args
643; values for the :description args
644(defun parse-method-group-specifiers (mgs)
645  (let (specs orders requireds descriptions)
646    (dolist (mg mgs)
647      (push nil specs)
648      (push :most-specific-first orders)
649      (push nil requireds)
650      (push nil descriptions)
651      (push (pop mg) (car specs))       ; name
652      (loop
653        (when (null mg) (return))
654        (when (memq (car mg) '(:order :required :description))
655          (destructuring-bind (&key (order :most-specific-first) required description)
656                              mg
657            (setf (car orders) order)
658            (setf (car requireds) required)
659            (setf (car descriptions) description))
660          (return))
661        (push (pop mg) (car specs)))
662      (setf (car specs) (nreverse (car specs))))
663    (values (nreverse specs)
664            (nreverse orders)
665            (nreverse requireds)
666            (nreverse descriptions))))
667
668(defun seperate-method-groups (methods specs orders requireds descriptions)
669  (declare (ignore descriptions))
670  (let ((res (make-list (length specs))))
671    (dolist (m methods)
672      (let ((res-tail res))
673        (dolist (s specs (%invalid-method-error
674                          m "Does not match any of the method group specifiers"))
675          (when (specifier-match-p (method-qualifiers m) s)
676            (push m (car res-tail))
677            (return))
678          (pop res-tail))))
679    (do ((res-tail res (cdr res-tail))
680         (o-tail orders (cdr o-tail))
681         (r-tail requireds (cdr r-tail)))
682        ((null res-tail))
683      (case (car o-tail)
684        (:most-specific-last)
685        (:most-specific-first (setf (car res-tail) (nreverse (car res-tail))))
686        (t (error "~s is neither ~s nor ~s" :most-specific-first :most-specific-last)))
687      (when (car r-tail)
688        (unless (car res-tail)
689          ; should use DESCRIPTIONS here
690          (error "A required method-group matched no method group specifiers"))))
691    res))
692
693(defun specifier-match-p (qualifiers spec)
694  (flet ((match (qs s)
695           (cond ((or (listp s) (eq s '*))
696                  (do ((qs-tail qs (cdr qs-tail))
697                       (s-tail s (cdr s-tail)))
698                      ((or (null qs-tail) (atom s-tail))
699                       (or (eq s-tail '*)
700                           (and (null qs-tail) (null s-tail))))
701                    (unless (or (eq (car s-tail) '*)
702                                (equal (car qs-tail) (car s-tail)))
703                      (return nil))))
704                 ((atom s) (funcall s qs))
705                 (t (error "Malformed method group specifier: ~s" spec)))))
706    (declare (inline match))
707    (dolist (s (cdr spec))
708      (when (match qualifiers s)
709        (return t)))))
710
711;;;;;;;
712;
713; The user visible error functions
714; We don't add any contextual information yet.
715; Maybe we never will.
716(setf (symbol-function 'method-combination-error) #'%method-combination-error)
717(setf (symbol-function 'invalid-method-error) #'%invalid-method-error)
718
719;;;;;;;
720;
721; The predefined method-combination types
722;
723(define-method-combination + :identity-with-one-argument t)
724(define-method-combination and :identity-with-one-argument t)
725(define-method-combination append :identity-with-one-argument t)
726(define-method-combination list :identity-with-one-argument nil)
727(define-method-combination max :identity-with-one-argument t)
728(define-method-combination min :identity-with-one-argument t)
729(define-method-combination nconc :identity-with-one-argument t)
730(define-method-combination or :identity-with-one-argument t)
731(define-method-combination progn :identity-with-one-argument t)
732
733; And evaluators for the non-functions
734(define-method-combination-evaluator and (methods args)
735  (when methods
736    (loop
737      (if (null (cdr methods))
738        (return (%%call-method* (car methods) nil args)))
739      (unless (%%call-method* (pop methods) nil args)
740        (return nil)))))
741
742(define-method-combination-evaluator or (methods args)
743  (when methods
744    (loop
745      (if (null (cdr methods))
746        (return (%%call-method* (car methods) nil args)))
747      (let ((res (%%call-method* (pop methods) nil args)))
748        (when res (return res))))))
749
750(define-method-combination-evaluator progn (methods args)
751  (when methods
752    (loop
753      (if (null (cdr methods))
754        (return (%%call-method* (car methods) nil args)))
755      (%%call-method* (pop methods) nil args))))
756
757#|
758
759;(define-method-combination and :identity-with-one-argument t)
760(defgeneric func (x) (:method-combination and))
761(defmethod func and ((x window)) (print 3))
762(defmethod func and ((x fred-window)) (print 2))
763(func (front-window))
764
765(define-method-combination example ()((methods positive-integer-qualifier-p))
766  `(progn ,@(mapcar #'(lambda (method)
767                        `(call-method ,method ()))
768                    (sort methods #'< :key #'(lambda (method)
769                                               (first (method-qualifiers method)))))))
770
771(defun positive-integer-qualifier-p (method-qualifiers)
772  (and (= (length method-qualifiers) 1)
773       (typep (first method-qualifiers)'(integer 0 *))))
774
775(defgeneric zork  (x)(:method-combination example))
776
777(defmethod zork 1 ((x window)) (print 1))
778(defmethod zork 2 ((x fred-window)) (print 2))
779(zork (front-window))
780
781
782|#
783
Note: See TracBrowser for help on using the repository browser.