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

Diff of /gcl/pcl/gcl_pcl_defcombin.lisp

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

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
1    ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
2    ;;;
3    ;;; *************************************************************************
4    ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5    ;;; All rights reserved.
6    ;;;
7    ;;; Use and copying of this software and preparation of derivative works
8    ;;; based upon this software are permitted.  Any distribution of this
9    ;;; software or derivative works must comply with all applicable United
10    ;;; States export control laws.
11    ;;;
12    ;;; This software is made available AS IS, and Xerox Corporation makes no
13    ;;; warranty about the software, its performance or its conformity to any
14    ;;; specification.
15    ;;;
16    ;;; Any person obtaining a copy of this software is requested to send their
17    ;;; name and post office or electronic mail address to:
18    ;;;   CommonLoops Coordinator
19    ;;;   Xerox PARC
20    ;;;   3333 Coyote Hill Rd.
21    ;;;   Palo Alto, CA 94304
22    ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23    ;;;
24    ;;; Suggestions, comments and requests for improvements are also welcome.
25    ;;; *************************************************************************
26    ;;;
27    
28    (in-package :pcl)
29    
30    ;;;
31    ;;; DEFINE-METHOD-COMBINATION
32    ;;;
33    
34    (defmacro define-method-combination (&whole form &rest args)
35      (declare (ignore args))
36      (if (and (cddr form)
37               (listp (caddr form)))
38          (expand-long-defcombin form)
39          (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
65    ;;;
66    ;;; The STANDARD method combination type is implemented directly by the class
67    ;;; STANDARD-METHOD-COMBINATION.  The method on COMPUTE-EFFECTIVE-METHOD does
68    ;;; standard method combination directly and is defined by hand in the file
69    ;;; combin.lisp.  The method for FIND-METHOD-COMBINATION must appear in this
70    ;;; file for bootstrapping reasons.
71    ;;;
72    ;;; A commented out copy of this definition appears in combin.lisp.
73    ;;; If you change this definition here, be sure to change it there
74    ;;; also.
75    ;;;
76    (defmethod find-method-combination ((generic-function generic-function)
77                                        (type (eql 'standard))
78                                        options)
79      (when options
80        (method-combination-error
81          "The method combination type STANDARD accepts no options."))
82      *standard-method-combination*)
83    
84    
85    
86    ;;;
87    ;;; short method combinations
88    ;;;
89    ;;; Short method combinations all follow the same rule for computing the
90    ;;; effective method.  So, we just implement that rule once.  Each short
91    ;;; method combination object just reads the parameters out of the object
92    ;;; and runs the same rule.
93    ;;;
94    ;;;
95    (defclass short-method-combination (standard-method-combination)
96         ((operator
97            :reader short-combination-operator
98            :initarg :operator)
99          (identity-with-one-argument
100            :reader short-combination-identity-with-one-argument
101            :initarg :identity-with-one-argument))
102      (:predicate-name short-method-combination-p))
103    
104    (defun expand-short-defcombin (whole)
105      (let* ((type (cadr whole))
106             (documentation
107               (getf (cddr whole) :documentation ""))
108             (identity-with-one-arg
109               (getf (cddr whole) :identity-with-one-argument nil))
110             (operator
111               (getf (cddr whole) :operator type)))
112        (make-top-level-form `(define-method-combination ,type)
113                             '(load eval)
114          `(load-short-defcombin
115             ',type ',operator ',identity-with-one-arg ',documentation))))
116    
117    (defun load-short-defcombin (type operator ioa doc)
118      (let* ((truename (load-truename))
119             (specializers
120               (list (find-class 'generic-function)
121                     (intern-eql-specializer type)
122                     *the-class-t*))
123             (old-method
124               (get-method #'find-method-combination () specializers nil))
125             (new-method nil))
126        (setq new-method
127              (make-instance 'standard-method
128                :qualifiers ()
129                :specializers specializers
130                :lambda-list '(generic-function type options)
131                :function (lambda (args nms &rest cm-args)
132                            (declare (ignore nms cm-args))
133                            (apply
134                             (lambda (gf type options)
135                               (declare (ignore gf))
136                               (make-short-method-combination
137                                   type options operator ioa new-method doc))
138                             args))
139                :definition-source `((define-method-combination ,type) ,truename)))
140        (when old-method
141          (remove-method #'find-method-combination old-method))
142        (add-method #'find-method-combination new-method)
143        type))
144    
145    (defun make-short-method-combination (type options operator ioa method doc)
146      (cond ((null options) (setq options '(:most-specific-first)))
147            ((equal options '(:most-specific-first)))
148            ((equal options '(:most-specific-last)))
149            (t
150             (method-combination-error
151               "Illegal options to a short method combination type.~%~
152                The method combination type ~S accepts one option which~%~
153                must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
154               type)))
155      (make-instance 'short-method-combination
156                     :type type
157                     :options options
158                     :operator operator
159                     :identity-with-one-argument ioa
160                     :definition-source method
161                     :documentation doc))
162    
163    (defmethod compute-effective-method ((generic-function generic-function)
164                                         (combin short-method-combination)
165                                         applicable-methods)
166      (let ((type (method-combination-type combin))
167            (operator (short-combination-operator combin))
168            (ioa (short-combination-identity-with-one-argument combin))
169            (order (car (method-combination-options combin)))
170            (around ())
171            (primary ())
172            (invalid ()))
173        (dolist (m applicable-methods)
174          (let ((qualifiers (method-qualifiers m)))
175            (labels ((lose (method why)
176                     (invalid-method-error
177                       method
178                       "The method ~S ~A.~%~
179                        The method combination type ~S was defined with the~%~
180                        short form of DEFINE-METHOD-COMBINATION and so requires~%~
181                        all methods have either the single qualifier ~S or the~%~
182                        single qualifier :AROUND."
183                       method why type type))
184                     (invalid-method (method why)
185                       (if *in-precompute-effective-methods-p*
186                           (push method invalid)
187                           (lose method why))))
188              (cond ((null qualifiers)
189                     (invalid-method m "has no qualifiers"))
190                    ((cdr qualifiers)
191                     (invalid-method m "has more than one qualifier"))
192                    ((eq (car qualifiers) :around)
193                     (push m around))
194                    ((eq (car qualifiers) type)
195                     (push m primary))
196                    (t
197                     (invalid-method m "has an illegal qualifier"))))))
198        (setq around (nreverse around))
199        (unless (eq order :most-specific-last)
200          (setq primary (nreverse primary)))
201        (let ((main-method
202                (if (and (null (cdr primary))
203                         (not (null ioa)))
204                    `(call-method ,(car primary) ())
205                    `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
206                                          primary)))))
207          (cond (invalid
208                 `(%invalid-qualifiers ',generic-function ',combin .args. ',invalid))
209                ((null primary)
210                 `(%no-primary-method ',generic-function .args.))
211                ((null around)
212                 main-method)
213                (t
214                 `(call-method ,(car around)
215                               (,@(cdr around) (make-method ,main-method))))))))
216    
217    
218    ;;;
219    ;;; long method combinations
220    ;;;
221    ;;;
222    
223    
224    (defun expand-long-defcombin (form)
225      (let ((type (cadr form))
226            (lambda-list (caddr form))
227            (method-group-specifiers (cadddr form))
228            (body (cddddr form))
229            (arguments-option ())
230            (gf-var nil))
231        (when (and (consp (car body)) (eq (caar body) :arguments))
232          (setq arguments-option (cdr (pop body))))
233        (when (and (consp (car body)) (eq (caar body) :generic-function))
234          (setq gf-var (cadr (pop body))))
235        (multiple-value-bind (documentation function)
236            (make-long-method-combination-function
237              type lambda-list method-group-specifiers arguments-option gf-var
238              body)
239          (make-top-level-form `(define-method-combination ,type)
240                               '(load eval)
241            `(load-long-defcombin ',type ',documentation #',function ',arguments-option)))))
242    
243    (defvar *long-method-combination-functions* (make-hash-table :test #'eq))
244    
245    (defun load-long-defcombin (type doc function arguments-lambda-list)
246      (let* ((specializers
247               (list (find-class 'generic-function)
248                     (intern-eql-specializer type)
249                     *the-class-t*))
250             (old-method
251               (get-method #'find-method-combination () specializers nil))
252             (new-method
253               (make-instance 'standard-method
254                 :qualifiers ()
255                 :specializers specializers
256                 :lambda-list '(generic-function type options)
257                 :function (lambda (args nms &rest cm-args)
258                             (declare (ignore nms cm-args))
259                             (apply
260                              (lambda (generic-function type options)
261                               (declare (ignore generic-function))
262                               (make-instance 'long-method-combination
263                                 :type type
264                                 :options options
265                                 :function function
266                                 :arguments-lambda-list
267                                 arguments-lambda-list
268                                 :documentation doc))
269                              args))
270                 :definition-source `((define-method-combination ,type)
271                                      ,(load-truename)))))
272        (setf (gethash type *long-method-combination-functions*) function)
273        (when old-method (remove-method #'find-method-combination old-method))
274        (add-method #'find-method-combination new-method)
275        type))
276    
277    (defmethod compute-effective-method ((generic-function generic-function)
278                                         (combin long-method-combination)
279                                         applicable-methods)
280      (funcall (gethash (method-combination-type combin)
281                        *long-method-combination-functions*)
282               generic-function
283               combin
284               applicable-methods))
285    
286    ;;;
287    ;;;
288    ;;;
289    (defun make-long-method-combination-function
290           (type ll method-group-specifiers arguments-option gf-var body)
291      (declare (ignore type))
292      (multiple-value-bind (documentation declarations real-body)
293          (extract-declarations body)
294    
295        (let ((wrapped-body
296                (wrap-method-group-specifier-bindings method-group-specifiers
297                                                      declarations
298                                                      real-body)))
299          (when gf-var
300            (push `(,gf-var .generic-function.) (cadr wrapped-body)))
301          
302          (when arguments-option
303            (setq wrapped-body
304                  (deal-with-arguments-option wrapped-body arguments-option)))
305    
306          (when ll
307            (setq wrapped-body
308                  `(apply (lambda ,ll ,wrapped-body)
309                          (method-combination-options .method-combination.))))
310    
311          (values
312            documentation
313            `(lambda (.generic-function. .method-combination. .applicable-methods.)
314               (declare (ignorable .generic-function. .method-combination.
315                                   .applicable-methods.))
316               (block .long-method-combination-function. ,wrapped-body))))))
317    ;;
318    ;; parse-method-group-specifiers parse the method-group-specifiers
319    ;;
320    
321    (defun wrap-method-group-specifier-bindings
322           (method-group-specifiers declarations real-body)
323      (let ((names ())
324            (specializer-caches ())
325            (cond-clauses ())
326            (required-checks ())
327            (order-cleanups ()))
328          (dolist (method-group-specifier method-group-specifiers)
329            (multiple-value-bind (name tests description order required)
330                (parse-method-group-specifier method-group-specifier)
331              (declare (ignore description))
332              (let ((specializer-cache (gensym)))
333                (push name names)
334                (push specializer-cache specializer-caches)
335                (push `((or ,@tests)
336                          (if  (and (equal ,specializer-cache .specializers.)
337                                    (not (null .specializers.)))
338                               (return-from .long-method-combination-function.
339                                 '(error "More than one method of type ~S ~
340                                          with the same specializers."
341                                         ',name))
342                               (setq ,specializer-cache .specializers.))
343                          (push .method. ,name))
344                        cond-clauses)
345                (when required
346                  (push `(when (null ,name)
347                             (return-from .long-method-combination-function.
348                               '(error "No ~S methods." ',name)))
349                          required-checks))
350                (loop (unless (and (constantp order)
351                                   (neq order (setq order (eval order))))
352                        (return t)))
353                (push (cond ((eq order :most-specific-first)
354                               `(setq ,name (nreverse ,name)))
355                              ((eq order :most-specific-last) ())
356                              (t
357                               `(ecase ,order
358                                  (:most-specific-first
359                                    (setq ,name (nreverse ,name)))
360                                  (:most-specific-last))))
361                        order-cleanups))))
362       `(let (,@(nreverse names) ,@(nreverse specializer-caches))
363          ,@declarations
364          (dolist (.method. .applicable-methods.)
365            (let ((.qualifiers. (method-qualifiers .method.))
366                  (.specializers. (method-specializers .method.)))
367              (declare (ignorable .qualifiers. .specializers.))
368              (cond ,@(nreverse cond-clauses))))
369          ,@(nreverse required-checks)
370          ,@(nreverse order-cleanups)
371          ,@real-body)))
372      
373    (defun parse-method-group-specifier (method-group-specifier)
374      ;;(declare (values name tests description order required))
375      (loop with name = (pop method-group-specifier)
376            for rest on method-group-specifier
377            for pattern = (car rest)
378            until (memq pattern '(:description :order :required))
379            collect pattern into patterns
380            collect (parse-qualifier-pattern name pattern) into tests
381            finally
382            (return (values name
383                tests
384                (getf rest :description
385                      (make-default-method-group-description
386                       (nreverse patterns)))
387                (getf rest :order :most-specific-first)
388                (getf rest :required nil)))))
389    
390    (defun parse-qualifier-pattern (name pattern)
391      (cond ((eq pattern '()) `(null .qualifiers.))
392            ((eq pattern '*) t)
393            ((symbolp pattern) `(,pattern .qualifiers.))
394            ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
395            (t (error "In the method group specifier ~S,~%~
396                       ~S isn't a valid qualifier pattern."
397                      name pattern))))
398    
399    (defun qualifier-check-runtime (pattern qualifiers)
400      (loop (cond ((and (null pattern) (null qualifiers))
401                   (return t))
402                  ((eq pattern '*) (return t))
403                  ((and pattern qualifiers
404                        (let ((element (car pattern)))
405                          (or (eq element (car qualifiers))
406                              (eq element '*))))
407                   (pop pattern)
408                   (pop qualifiers))              
409                  (t (return nil)))))
410    
411    (defun make-default-method-group-description (patterns)
412      (if (cdr patterns)
413          (format nil
414                  "methods matching one of the patterns: ~{~S, ~} ~S"
415                  (butlast patterns) (car (last patterns)))
416          (format nil
417                  "methods matching the pattern: ~S"
418                  (car patterns))))
419    
420    ;;;
421    ;;; Return a form that deals with the :ARGUMENTS lambda-list of a long
422    ;;; method combination.  WRAPPED-BODY is the body of the method
423    ;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments
424    ;;; lambda-list of the method combination.
425    ;;;
426    (defun deal-with-arguments-option (wrapped-body arguments-lambda-list)
427      (let ((intercept-rebindings
428             (loop for arg in arguments-lambda-list
429                   unless (memq arg lambda-list-keywords)
430                   collect `(,arg ',arg)))
431            (nreq 0)
432            (nopt 0)
433            whole)
434        ;;
435        ;; Count the number of required and optional parameters in
436        ;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
437        ;; name of a &WHOLE parameter, if any.
438        (loop with state = 'required
439              for arg in arguments-lambda-list do
440                (if (memq arg lambda-list-keywords)
441                    (setq state arg)
442                    (case state
443                      (required (incf nreq))
444                      (&optional (incf nopt))
445                      (&whole (setq whole arg
446                                    state 'required)))))
447        ;;
448        ;; This assumes that the WRAPPED-BODY is a let/let* form, and it
449        ;; injects let-bindings of the form (ARG 'SYM) for all variables
450        ;; of the argument-lambda-list; SYM is a gensym.
451        (assert (memq (first wrapped-body) '(let let*)))
452        (setf (second wrapped-body)
453              (append intercept-rebindings (second wrapped-body)))
454        ;;
455        ;; Be sure to fill out the args lambda list so that it can be too
456        ;; short if it wants to.
457        (unless (or (memq '&rest arguments-lambda-list)
458                    (memq '&allow-other-keys arguments-lambda-list))
459          (let ((aux (memq '&aux arguments-lambda-list)))
460            (setq arguments-lambda-list
461                  (append (ldiff arguments-lambda-list aux)
462                          (if (memq '&key arguments-lambda-list)
463                              '(&allow-other-keys)
464                              '(&rest .ignore.))
465                          aux))))
466        ;;
467        ;; .GENERIC-FUNCTION. is bound to the generic function in the
468        ;; method combination function, and .GF-ARGS* is bound to the
469        ;; generic function arguments in effective method functions
470        ;; created for generic functions having a method combination that
471        ;; uses :ARGUMENTS.
472        ;;
473        ;; The DESTRUCTURING-BIND binds the parameters of the
474        ;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments.
475        ;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the
476        ;; generic function's lambda list, which is only known at run time,
477        ;; this destructuring has to be done on a slighly modified list of
478        ;; actual arguments, from which values might be stripped or added.
479        ;;
480        ;; Using one of the variable names in the body inserts a symbol
481        ;; into the effective method, and running the effective method
482        ;; produces the value of actual argument that is bound to the
483        ;; symbol.
484        `(let ((inner-result. ,wrapped-body)
485               (gf-lambda-list (generic-function-lambda-list .generic-function.)))
486           `(destructuring-bind ,',arguments-lambda-list
487                (frob-combined-method-args
488                 .gf-args. ',gf-lambda-list
489                 ,',nreq ,',nopt)
490              ,,(when (memq '.ignore. arguments-lambda-list)
491                  ''(declare (ignore .ignore.)))
492              ;; If there is a &WHOLE in the arguments-lambda-list, let
493              ;; it result in the actual arguments of the generic-function
494              ;; not the frobbed list.
495              ,,(when whole
496                  ``(setq ,',whole .gf-args.))
497              ,inner-result.))))
498    
499    ;;;
500    ;;; Partition VALUES into three sections required, optional, and the
501    ;;; rest, according to required, optional, and other parameters in
502    ;;; LAMBDA-LIST.  Make the required and optional sections NREQ and
503    ;;; NOPT elements long by discarding values or adding NILs.  Value is
504    ;;; the concatenated list of required and optional sections, and what
505    ;;; is left as rest from VALUES.
506    ;;;
507    (defun frob-combined-method-args (values lambda-list nreq nopt)
508      (loop with section = 'required
509            for arg in lambda-list
510            if (memq arg lambda-list-keywords) do
511              (setq section arg)
512              (unless (eq section '&optional)
513                (loop-finish))
514            else if (eq section 'required)
515              count t into nr
516              and collect (pop values) into required
517            else if (eq section '&optional)
518              count t into no
519              and collect (pop values) into optional
520            finally
521              (flet ((frob (list n m)
522                       (cond ((> n m) (butlast list (- n m)))
523                             ((< n m) (nconc list (make-list (- m n))))
524                             (t list))))
525                (return (nconc (frob required nr nreq)
526                               (frob optional no nopt)
527                               values)))))

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