source: branches/qres/ccl/lib/method-combination.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

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