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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Aug 12 03:46:05 1990 UTC (23 years, 8 months ago) by wlott
Branch: MAIN
Initial revision
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

  ViewVC Help
Powered by ViewVC 1.1.5