← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to pcl/pcl_defcombin.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
pcl/pcl_defcombin.lisp
 
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
    (dolist (m applicable-methods)
 
173
      (let ((qualifiers (method-qualifiers m)))
 
174
        (flet ((lose (method why)
 
175
                 (invalid-method-error
 
176
                   method
 
177
                   "The method ~S ~A.~%~
 
178
                    The method combination type ~S was defined with the~%~
 
179
                    short form of DEFINE-METHOD-COMBINATION and so requires~%~
 
180
                    all methods have either the single qualifier ~S or the~%~
 
181
                    single qualifier :AROUND."
 
182
                   method why type type)))
 
183
          (cond ((null qualifiers)
 
184
                 (lose m "has no qualifiers"))
 
185
                ((cdr qualifiers)
 
186
                 (lose m "has more than one qualifier"))
 
187
                ((eq (car qualifiers) :around)
 
188
                 (push m around))
 
189
                ((eq (car qualifiers) type)
 
190
                 (push m primary))
 
191
                (t
 
192
                 (lose m "has an illegal qualifier"))))))
 
193
    (setq around (nreverse around))
 
194
    (unless (eq order :most-specific-last)
 
195
      (setq primary (nreverse primary)))
 
196
    (let ((main-method
 
197
            (if (and (null (cdr primary))
 
198
                     (not (null ioa)))
 
199
                `(call-method ,(car primary) ())
 
200
                `(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
 
201
                                      primary)))))
 
202
      (cond ((null primary)
 
203
             `(error "No ~S methods for the generic function ~S."
 
204
                     ',type ',generic-function))
 
205
            ((null around) main-method)
 
206
            (t
 
207
             `(call-method ,(car around)
 
208
                           (,@(cdr around) (make-method ,main-method))))))))
 
209
 
 
210
 
 
211
;;;
 
212
;;; long method combinations
 
213
;;;
 
214
;;;
 
215
 
 
216
 
 
217
(defun expand-long-defcombin (form)
 
218
  (let ((type (cadr form))
 
219
        (lambda-list (caddr form))
 
220
        (method-group-specifiers (cadddr form))
 
221
        (body (cddddr form))
 
222
        (arguments-option ())
 
223
        (gf-var nil))
 
224
    (when (and (consp (car body)) (eq (caar body) :arguments))
 
225
      (setq arguments-option (cdr (pop body))))
 
226
    (when (and (consp (car body)) (eq (caar body) :generic-function))
 
227
      (setq gf-var (cadr (pop body))))
 
228
    (multiple-value-bind (documentation function)
 
229
        (make-long-method-combination-function
 
230
          type lambda-list method-group-specifiers arguments-option gf-var
 
231
          body)
 
232
      (make-top-level-form `(define-method-combination ,type)
 
233
                           '(load eval)
 
234
        `(load-long-defcombin ',type ',documentation #',function ',arguments-option)))))
 
235
 
 
236
(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
 
237
 
 
238
(defun load-long-defcombin (type doc function arguments-lambda-list)
 
239
  (let* ((specializers
 
240
           (list (find-class 'generic-function)
 
241
                 (intern-eql-specializer type)
 
242
                 *the-class-t*))
 
243
         (old-method
 
244
           (get-method #'find-method-combination () specializers nil))
 
245
         (new-method
 
246
           (make-instance 'standard-method
 
247
             :qualifiers ()
 
248
             :specializers specializers
 
249
             :lambda-list '(generic-function type options)
 
250
             :function (lambda (args nms &rest cm-args)
 
251
                         (declare (ignore nms cm-args))
 
252
                         (apply
 
253
                          (lambda (generic-function type options)
 
254
                           (declare (ignore generic-function))
 
255
                           (make-instance 'long-method-combination
 
256
                             :type type
 
257
                             :options options
 
258
                             :function function
 
259
                             :arguments-lambda-list
 
260
                             arguments-lambda-list
 
261
                             :documentation doc))
 
262
                          args))
 
263
             :definition-source `((define-method-combination ,type)
 
264
                                  ,(load-truename)))))
 
265
    (setf (gethash type *long-method-combination-functions*) function)
 
266
    (when old-method (remove-method #'find-method-combination old-method))
 
267
    (add-method #'find-method-combination new-method)
 
268
    type))
 
269
 
 
270
(defmethod compute-effective-method ((generic-function generic-function)
 
271
                                     (combin long-method-combination)
 
272
                                     applicable-methods)
 
273
  (funcall (gethash (method-combination-type combin)
 
274
                    *long-method-combination-functions*)
 
275
           generic-function
 
276
           combin
 
277
           applicable-methods))
 
278
 
 
279
;;;
 
280
;;;
 
281
;;;
 
282
(defun make-long-method-combination-function
 
283
       (type ll method-group-specifiers arguments-option gf-var body)
 
284
  (declare (ignore type))
 
285
  (multiple-value-bind (documentation declarations real-body)
 
286
      (extract-declarations body)
 
287
 
 
288
    (let ((wrapped-body
 
289
            (wrap-method-group-specifier-bindings method-group-specifiers
 
290
                                                  declarations
 
291
                                                  real-body)))
 
292
      (when gf-var
 
293
        (push `(,gf-var .generic-function.) (cadr wrapped-body)))
 
294
      
 
295
      (when arguments-option
 
296
        (setq wrapped-body
 
297
              (deal-with-arguments-option wrapped-body arguments-option)))
 
298
 
 
299
      (when ll
 
300
        (setq wrapped-body
 
301
              `(apply (lambda ,ll ,wrapped-body)
 
302
                      (method-combination-options .method-combination.))))
 
303
 
 
304
      (values
 
305
        documentation
 
306
        `(lambda (.generic-function. .method-combination. .applicable-methods.)
 
307
           (declare (ignorable .generic-function. .method-combination.
 
308
                               .applicable-methods.))
 
309
           (block .long-method-combination-function. ,wrapped-body))))))
 
310
;;
 
311
;; parse-method-group-specifiers parse the method-group-specifiers
 
312
;;
 
313
 
 
314
(defun wrap-method-group-specifier-bindings
 
315
       (method-group-specifiers declarations real-body)
 
316
  (let ((names ())
 
317
        (specializer-caches ())
 
318
        (cond-clauses ())
 
319
        (required-checks ())
 
320
        (order-cleanups ()))
 
321
      (dolist (method-group-specifier method-group-specifiers)
 
322
        (multiple-value-bind (name tests description order required)
 
323
            (parse-method-group-specifier method-group-specifier)
 
324
          (declare (ignore description))
 
325
          (let ((specializer-cache (gensym)))
 
326
            (push name names)
 
327
            (push specializer-cache specializer-caches)
 
328
            (push `((or ,@tests)
 
329
                      (if  (and (equal ,specializer-cache .specializers.)
 
330
                                (not (null .specializers.)))
 
331
                           (return-from .long-method-combination-function.
 
332
                             '(error "More than one method of type ~S ~
 
333
                                      with the same specializers."
 
334
                                     ',name))
 
335
                           (setq ,specializer-cache .specializers.))
 
336
                      (push .method. ,name))
 
337
                    cond-clauses)
 
338
            (when required
 
339
              (push `(when (null ,name)
 
340
                         (return-from .long-method-combination-function.
 
341
                           '(error "No ~S methods." ',name)))
 
342
                      required-checks))
 
343
            (loop (unless (and (constantp order)
 
344
                               (neq order (setq order (eval order))))
 
345
                    (return t)))
 
346
            (push (cond ((eq order :most-specific-first)
 
347
                           `(setq ,name (nreverse ,name)))
 
348
                          ((eq order :most-specific-last) ())
 
349
                          (t
 
350
                           `(ecase ,order
 
351
                              (:most-specific-first
 
352
                                (setq ,name (nreverse ,name)))
 
353
                              (:most-specific-last))))
 
354
                    order-cleanups))))
 
355
   `(let (,@(nreverse names) ,@(nreverse specializer-caches))
 
356
      ,@declarations
 
357
      (dolist (.method. .applicable-methods.)
 
358
        (let ((.qualifiers. (method-qualifiers .method.))
 
359
              (.specializers. (method-specializers .method.)))
 
360
          (declare (ignorable .qualifiers. .specializers.))
 
361
          (cond ,@(nreverse cond-clauses))))
 
362
      ,@(nreverse required-checks)
 
363
      ,@(nreverse order-cleanups)
 
364
      ,@real-body)))
 
365
   
 
366
(defun parse-method-group-specifier (method-group-specifier)
 
367
  ;;(declare (values name tests description order required))
 
368
  (loop with name = (pop method-group-specifier)
 
369
        for rest on method-group-specifier
 
370
        for pattern = (car rest)
 
371
        until (memq pattern '(:description :order :required))
 
372
        collect pattern into patterns
 
373
        collect (parse-qualifier-pattern name pattern) into tests
 
374
        finally
 
375
        (return (values name
 
376
            tests
 
377
            (getf rest :description
 
378
                  (make-default-method-group-description 
 
379
                   (nreverse patterns)))
 
380
            (getf rest :order :most-specific-first)
 
381
            (getf rest :required nil)))))
 
382
 
 
383
(defun parse-qualifier-pattern (name pattern)
 
384
  (cond ((eq pattern '()) `(null .qualifiers.))
 
385
        ((eq pattern '*) t)
 
386
        ((symbolp pattern) `(,pattern .qualifiers.))
 
387
        ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
 
388
        (t (error "In the method group specifier ~S,~%~
 
389
                   ~S isn't a valid qualifier pattern."
 
390
                  name pattern))))
 
391
 
 
392
(defun qualifier-check-runtime (pattern qualifiers)
 
393
  (loop (cond ((and (null pattern) (null qualifiers))
 
394
               (return t))
 
395
              ((eq pattern '*) (return t))
 
396
              ((and pattern qualifiers 
 
397
                    (let ((element (car pattern)))
 
398
                      (or (eq element (car qualifiers))
 
399
                          (eq element '*))))
 
400
               (pop pattern)
 
401
               (pop qualifiers))              
 
402
              (t (return nil)))))
 
403
 
 
404
(defun make-default-method-group-description (patterns)
 
405
  (if (cdr patterns)
 
406
      (format nil
 
407
              "methods matching one of the patterns: ~{~S, ~} ~S"
 
408
              (butlast patterns) (car (last patterns)))
 
409
      (format nil
 
410
              "methods matching the pattern: ~S"
 
411
              (car patterns))))
 
412
 
 
413
;;;
 
414
;;; Return a form that deals with the :ARGUMENTS lambda-list of a long
 
415
;;; method combination.  WRAPPED-BODY is the body of the method
 
416
;;; combination so far, and ARGUMENTS-LAMBDA-LIST is the arguments
 
417
;;; lambda-list of the method combination.
 
418
;;;
 
419
(defun deal-with-arguments-option (wrapped-body arguments-lambda-list)
 
420
  (let ((intercept-rebindings
 
421
         (loop for arg in arguments-lambda-list
 
422
               unless (memq arg lambda-list-keywords)
 
423
               collect `(,arg ',arg)))
 
424
        (nreq 0)
 
425
        (nopt 0)
 
426
        whole)
 
427
    ;;
 
428
    ;; Count the number of required and optional parameters in
 
429
    ;; ARGUMENTS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
 
430
    ;; name of a &WHOLE parameter, if any.
 
431
    (loop with state = 'required
 
432
          for arg in arguments-lambda-list do
 
433
            (if (memq arg lambda-list-keywords)
 
434
                (setq state arg)
 
435
                (case state
 
436
                  (required (incf nreq))
 
437
                  (&optional (incf nopt))
 
438
                  (&whole (setq whole arg
 
439
                                state 'required)))))
 
440
    ;;
 
441
    ;; This assumes that the WRAPPED-BODY is a let/let* form, and it
 
442
    ;; injects let-bindings of the form (ARG 'SYM) for all variables
 
443
    ;; of the argument-lambda-list; SYM is a gensym.
 
444
    (assert (memq (first wrapped-body) '(let let*)))
 
445
    (setf (second wrapped-body)
 
446
          (append intercept-rebindings (second wrapped-body)))
 
447
    ;;
 
448
    ;; Be sure to fill out the args lambda list so that it can be too
 
449
    ;; short if it wants to.
 
450
    (unless (or (memq '&rest arguments-lambda-list)
 
451
                (memq '&allow-other-keys arguments-lambda-list))
 
452
      (let ((aux (memq '&aux arguments-lambda-list)))
 
453
        (setq arguments-lambda-list
 
454
              (append (ldiff arguments-lambda-list aux)
 
455
                      (if (memq '&key arguments-lambda-list)
 
456
                          '(&allow-other-keys)
 
457
                          '(&rest .ignore.))
 
458
                      aux))))
 
459
    ;;
 
460
    ;; .GENERIC-FUNCTION. is bound to the generic function in the
 
461
    ;; method combination function, and .GF-ARGS* is bound to the
 
462
    ;; generic function arguments in effective method functions
 
463
    ;; created for generic functions having a method combination that
 
464
    ;; uses :ARGUMENTS.
 
465
    ;;
 
466
    ;; The DESTRUCTURING-BIND binds the parameters of the
 
467
    ;; ARGUMENTS-LAMBDA-LIST to actual generic function arguments.
 
468
    ;; Because ARGUMENTS-LAMBDA-LIST may be shorter or longer than the
 
469
    ;; generic function's lambda list, which is only known at run time,
 
470
    ;; this destructuring has to be done on a slighly modified list of
 
471
    ;; actual arguments, from which values might be stripped or added.
 
472
    ;;
 
473
    ;; Using one of the variable names in the body inserts a symbol
 
474
    ;; into the effective method, and running the effective method
 
475
    ;; produces the value of actual argument that is bound to the
 
476
    ;; symbol.
 
477
    `(let ((inner-result. ,wrapped-body)
 
478
           (gf-lambda-list (generic-function-lambda-list .generic-function.)))
 
479
       `(destructuring-bind ,',arguments-lambda-list
 
480
            (frob-combined-method-args
 
481
             .gf-args. ',gf-lambda-list
 
482
             ,',nreq ,',nopt)
 
483
          ,,(when (memq '.ignore. arguments-lambda-list)
 
484
              ''(declare (ignore .ignore.)))
 
485
          ;; If there is a &WHOLE in the arguments-lambda-list, let
 
486
          ;; it result in the actual arguments of the generic-function
 
487
          ;; not the frobbed list.
 
488
          ,,(when whole
 
489
              ``(setq ,',whole .gf-args.))
 
490
          ,inner-result.))))
 
491
 
 
492
;;;
 
493
;;; Partition VALUES into three sections required, optional, and the
 
494
;;; rest, according to required, optional, and other parameters in
 
495
;;; LAMBDA-LIST.  Make the required and optional sections NREQ and
 
496
;;; NOPT elements long by discarding values or adding NILs.  Value is
 
497
;;; the concatenated list of required and optional sections, and what
 
498
;;; is left as rest from VALUES.
 
499
;;;
 
500
(defun frob-combined-method-args (values lambda-list nreq nopt)
 
501
  (loop with section = 'required
 
502
        for arg in lambda-list
 
503
        if (memq arg lambda-list-keywords) do
 
504
          (setq section arg)
 
505
          (unless (eq section '&optional)
 
506
            (loop-finish))
 
507
        else if (eq section 'required)
 
508
          count t into nr
 
509
          and collect (pop values) into required
 
510
        else if (eq section '&optional)
 
511
          count t into no
 
512
          and collect (pop values) into optional
 
513
        finally
 
514
          (flet ((frob (list n m)
 
515
                   (cond ((> n m) (butlast list (- n m)))
 
516
                         ((< n m) (nconc list (make-list (- m n))))
 
517
                         (t list))))
 
518
            (return (nconc (frob required nr nreq)
 
519
                           (frob optional no nopt)
 
520
                           values)))))