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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Sat Oct 19 17:21:59 1991 UTC (22 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.1: +1 -0 lines
Merged with latest PCL version.
1 wlott 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     (defun make-effective-method-function (generic-function form)
31     (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
32     (if (and (listp form)
33     (eq (car form) 'call-method)
34     (method-p (cadr form))
35     (every #'method-p (caddr form)))
36     ;;
37     ;; The effective method is just a call to call-method. This opens up
38     ;; the possibility of just using the method function of the method as
39     ;; as the effective method function.
40     ;;
41     ;; But we have to be careful. If that method function will ask for
42     ;; the next methods we have to provide them. We do not look to see
43     ;; if there are next methods, we look at whether the method function
44     ;; asks about them. If it does, we must tell it whether there are
45     ;; or aren't to prevent the leaky next methods bug.
46     ;;
47     (let* ((method-function (method-function (cadr form)))
48     (arg-info (gf-arg-info generic-function))
49     (metatypes (arg-info-metatypes arg-info))
50     (applyp (arg-info-applyp arg-info)))
51     (if (not (method-function-needs-next-methods-p method-function))
52     method-function
53     (let ((next-method-functions (mapcar #'method-function (caddr form))))
54     (name-function
55     (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
56     (let ((*next-methods* .next-method-functions.))
57     ,(make-dfun-call metatypes applyp '.method-function.)))
58     #'default-test-converter ;This could be optimized by making
59     ;the interface from here to the
60     ;walker more clear so that the
61     ;form wouldn't get walked at all.
62     #'(lambda (form)
63     (if (memq form '(.next-method-functions. .method-function.))
64     (values form (list form))
65     form))
66     #'(lambda (form)
67     (cond ((eq form '.next-method-functions.)
68     (list next-method-functions))
69     ((eq form '.method-function.)
70     (list method-function)))))))))
71     ;;
72     ;; We have some sort of `real' effective method. Go off and get a
73     ;; compiled function for it. Most of the real hair here is done by
74     ;; the GET-FUNCTION mechanism.
75     ;;
76     (name-function (make-effective-method-function-internal generic-function form)))))
77    
78     (defvar *global-effective-method-gensyms* ())
79     (defvar *rebound-effective-method-gensyms*)
80    
81     (defun get-effective-method-gensym ()
82     (or (pop *rebound-effective-method-gensyms*)
83     (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
84     (push new *global-effective-method-gensyms*)
85     new)))
86    
87     (eval-when (load)
88     (let ((*rebound-effective-method-gensyms* ()))
89     (dotimes (i 10) (get-effective-method-gensym))))
90    
91     (defun make-effective-method-function-internal (generic-function effective-method)
92     (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
93     (arg-info (gf-arg-info generic-function))
94     (metatypes (arg-info-metatypes arg-info))
95     (applyp (arg-info-applyp arg-info)))
96     (labels ((test-converter (form)
97     (if (and (consp form) (eq (car form) 'call-method))
98     '.call-method.
99     (default-test-converter form)))
100     (code-converter (form)
101     (if (and (consp form) (eq (car form) 'call-method))
102     ;;
103     ;; We have a `call' to CALL-METHOD. There may or may not be next methods
104     ;; and the two cases are a little different. It controls how many gensyms
105     ;; we will generate.
106     ;;
107     (let ((gensyms
108     (if (cddr form)
109     (list (get-effective-method-gensym)
110     (get-effective-method-gensym))
111     (list (get-effective-method-gensym)
112     ()))))
113     (values `(let ((*next-methods* ,(cadr gensyms)))
114     ,(make-dfun-call metatypes applyp (car gensyms)))
115     gensyms))
116     (default-code-converter form)))
117     (constant-converter (form)
118     (if (and (consp form) (eq (car form) 'call-method))
119     (if (cddr form)
120     (list (check-for-make-method (cadr form))
121     (mapcar #'check-for-make-method (caddr form)))
122     (list (check-for-make-method (cadr form))
123     ()))
124     (default-constant-converter form)))
125     (check-for-make-method (effective-method)
126     (cond ((method-p effective-method)
127     (method-function effective-method))
128     ((and (listp effective-method)
129     (eq (car effective-method) 'make-method))
130     (make-effective-method-function generic-function
131     (make-progn (cadr effective-method))))
132     (t
133     (error "Effective-method form is malformed.")))))
134     (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
135     #'test-converter
136     #'code-converter
137     #'constant-converter))))
138    
139    
140    
141     (defvar *invalid-method-error*
142     #'(lambda (&rest args)
143     (declare (ignore args))
144     (error
145     "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
146     of a method combination function (inside the body of~%~
147     DEFINE-METHOD-COMBINATION or a method on the generic~%~
148     function COMPUTE-EFFECTIVE-METHOD).")))
149    
150     (defvar *method-combination-error*
151     #'(lambda (&rest args)
152     (declare (ignore args))
153     (error
154     "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
155     of a method combination function (inside the body of~%~
156     DEFINE-METHOD-COMBINATION or a method on the generic~%~
157     function COMPUTE-EFFECTIVE-METHOD).")))
158    
159     ;(defmethod compute-effective-method :around ;issue with magic
160     ; ((generic-function generic-function) ;generic functions
161     ; (method-combination method-combination)
162     ; applicable-methods)
163     ; (declare (ignore applicable-methods))
164     ; (flet ((real-invalid-method-error (method format-string &rest args)
165     ; (declare (ignore method))
166     ; (apply #'error format-string args))
167     ; (real-method-combination-error (format-string &rest args)
168     ; (apply #'error format-string args)))
169     ; (let ((*invalid-method-error* #'real-invalid-method-error)
170     ; (*method-combination-error* #'real-method-combination-error))
171     ; (call-next-method))))
172    
173     (defun invalid-method-error (&rest args)
174     (declare (arglist method format-string &rest format-arguments))
175     (apply *invalid-method-error* args))
176    
177     (defun method-combination-error (&rest args)
178     (declare (arglist format-string &rest format-arguments))
179     (apply *method-combination-error* args))
180    
181    
182    
183     ;;;
184     ;;; The STANDARD method combination type. This is coded by hand (rather than
185     ;;; with define-method-combination) for bootstrapping and efficiency reasons.
186     ;;; Note that the definition of the find-method-combination-method appears in
187     ;;; the file defcombin.lisp, this is because EQL methods can't appear in the
188     ;;; bootstrap.
189     ;;;
190     ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
191     ;;; classes has to appear here for this reason. This code must conform to
192     ;;; the code in the file defcombin, look there for more details.
193     ;;;
194    
195     (defclass method-combination () ())
196    
197     (define-gf-predicate method-combination-p method-combination)
198    
199     (defclass standard-method-combination
200     (definition-source-mixin method-combination)
201     ((type :reader method-combination-type
202     :initarg :type)
203     (documentation :reader method-combination-documentation
204     :initarg :documentation)
205     (options :reader method-combination-options
206     :initarg :options)))
207    
208     (defmethod print-object ((mc method-combination) stream)
209     (printing-random-thing (mc stream)
210     (format stream
211     "Method-Combination ~S ~S"
212     (method-combination-type mc)
213     (method-combination-options mc))))
214    
215     (eval-when (load eval)
216     (setq *standard-method-combination*
217     (make-instance 'standard-method-combination
218     :type 'standard
219     :documentation "The standard method combination."
220     :options ())))
221    
222     ;This definition appears in defcombin.lisp.
223     ;
224     ;(defmethod find-method-combination ((generic-function generic-function)
225     ; (type (eql 'standard))
226     ; options)
227     ; (when options
228     ; (method-combination-error
229     ; "The method combination type STANDARD accepts no options."))
230     ; *standard-method-combination*)
231    
232     (defun make-call-methods (methods)
233     (mapcar #'(lambda (method) `(call-method ,method ())) methods))
234    
235     (defmethod compute-effective-method ((generic-function generic-function)
236     (combin standard-method-combination)
237     applicable-methods)
238     (let ((before ())
239     (primary ())
240     (after ())
241     (around ()))
242     (dolist (m applicable-methods)
243     (let ((qualifiers (method-qualifiers m)))
244     (cond ((member ':before qualifiers) (push m before))
245     ((member ':after qualifiers) (push m after))
246     ((member ':around qualifiers) (push m around))
247     (t
248     (push m primary)))))
249     (setq before (reverse before)
250     after (reverse after)
251     primary (reverse primary)
252     around (reverse around))
253     (cond ((null primary)
254     `(error "No primary method for the generic function ~S." ',generic-function))
255     ((and (null before) (null after) (null around))
256     ;;
257     ;; By returning a single call-method `form' here we enable an important
258     ;; implementation-specific optimization.
259     ;;
260     `(call-method ,(first primary) ,(rest primary)))
261     (t
262     (let ((main-effective-method
263     (if (or before after (rest primary))
264     `(multiple-value-prog1
265     (progn ,@(make-call-methods before)
266     (call-method ,(first primary) ,(rest primary)))
267     ,@(make-call-methods (reverse after)))
268     `(call-method ,(first primary) ()))))
269     (if around
270     `(call-method ,(first around)
271     (,@(rest around) (make-method ,main-effective-method)))
272     main-effective-method))))))
273    
274 ram 1.2

  ViewVC Help
Powered by ViewVC 1.1.5