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

Contents of /src/pcl/boot.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78 - (show annotations)
Mon Apr 19 02:31:13 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.77: +3 -3 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;;-*-Mode: LISP; Package:(PCL LISP 1000); 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 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/boot.lisp,v 1.78 2010/04/19 02:31:13 rtoy Rel $")
29
30 (in-package :pcl)
31 (intl:textdomain "cmucl")
32
33 #|
34
35 The CommonLoops evaluator is meta-circular.
36
37 Most of the code in PCL is methods on generic functions, including most of
38 the code that actually implements generic functions and method lookup.
39
40 So, we have a classic bootstrapping problem. The solution to this is to
41 first get a cheap implementation of generic functions running, these are
42 called early generic functions. These early generic functions and the
43 corresponding early methods and early method lookup are used to get enough
44 of the system running that it is possible to create real generic functions
45 and methods and implement real method lookup. At that point (done in the
46 file FIXUP) the function fix-early-generic-functions is called to convert
47 all the early generic functions to real generic functions.
48
49 The cheap generic functions are built using the same funcallable-instance
50 objects real generic-functions are made out of. This means that as PCL
51 is being bootstrapped, the cheap generic function objects which are being
52 created are the same objects which will later be real generic functions.
53 This is good because:
54 - we don't cons garbage structure
55 - we can keep pointers to the cheap generic function objects
56 during booting because those pointers will still point to
57 the right object after the generic functions are all fixed
58 up
59
60
61
62 This file defines the defmethod macro and the mechanism used to expand it.
63 This includes the mechanism for processing the body of a method. defmethod
64 basically expands into a call to load-defmethod, which basically calls
65 add-method to add the method to the generic-function. These expansions can
66 be loaded either during bootstrapping or when PCL is fully up and running.
67
68 An important effect of this structure is it means we can compile files with
69 defmethod forms in them in a completely running PCL, but then load those files
70 back in during bootstrapping. This makes development easier. It also means
71 there is only one set of code for processing defmethod. Bootstrapping works
72 by being sure to have load-method be careful to call only primitives which
73 work during bootstrapping.
74
75 |#
76
77 (declaim (notinline make-a-method
78 add-named-method
79 ensure-generic-function-using-class
80 add-method
81 remove-method
82 ))
83
84 (defvar *early-functions*
85 '((make-a-method early-make-a-method
86 real-make-a-method)
87 (add-named-method early-add-named-method
88 real-add-named-method)))
89
90 ;;;
91 ;;; For each of the early functions, arrange to have it point to its early
92 ;;; definition. Do this in a way that makes sure that if we redefine one
93 ;;; of the early definitions the redefinition will take effect. This makes
94 ;;; development easier.
95 ;;;
96 ;;; The function which generates the redirection closure is pulled out into
97 ;;; a separate piece of code because of a bug in ExCL which causes this not
98 ;;; to work if it is inlined.
99 ;;;
100 #-loadable-pcl
101 (eval-when (:load-toplevel :execute)
102
103 (defun redirect-early-function-internal (real early)
104 (setf (gdefinition real)
105 (set-function-name
106 (lambda (&rest args)
107 (apply (the function (symbol-function early)) args))
108 real)))
109
110 (dolist (fns *early-functions*)
111 (let ((name (car fns))
112 (early-name (cadr fns)))
113 (redirect-early-function-internal name early-name)))
114 )
115
116
117 ;;;
118 ;;; *generic-function-fixups* is used by fix-early-generic-functions to
119 ;;; convert the few functions in the bootstrap which are supposed to be
120 ;;; generic functions but can't be early on.
121 ;;;
122 (defvar *generic-function-fixups*
123 '((add-method
124 ((generic-function method) ;lambda-list
125 (standard-generic-function method) ;specializers
126 real-add-method)) ;method-function
127 (remove-method
128 ((generic-function method)
129 (standard-generic-function method)
130 real-remove-method))
131 (get-method
132 ((generic-function qualifiers specializers &optional (errorp t))
133 (standard-generic-function t t)
134 real-get-method))
135 (ensure-generic-function-using-class
136 ((generic-function function-specifier
137 &key generic-function-class environment
138 &allow-other-keys)
139 (generic-function t)
140 real-ensure-gf-using-class--generic-function)
141 ((generic-function function-specifier
142 &key generic-function-class environment
143 &allow-other-keys)
144 (null t)
145 real-ensure-gf-using-class--null))
146 (make-method-lambda
147 ((proto-generic-function proto-method lambda-expression environment)
148 (standard-generic-function standard-method t t)
149 real-make-method-lambda))
150 (make-method-initargs-form
151 ((proto-generic-function proto-method lambda-expression lambda-list environment)
152 (standard-generic-function standard-method t t t)
153 real-make-method-initargs-form))
154 (compute-effective-method
155 ((generic-function combin applicable-methods)
156 (generic-function standard-method-combination t)
157 standard-compute-effective-method))
158 ))
159
160
161 ;;;
162 ;;;
163 ;;;
164 (defun tell-compiler-about-gf (function-specifier lambda-list)
165 ;; Supress any undefined function warnings from compiler.
166 ;; I had originally lifted some code from c::%%defun but this
167 ;; seems to do the job just as well.
168 (proclaim-defgeneric function-specifier lambda-list))
169
170 ;;;
171 ;;; ANSI 3.4.2, Generic Function Lambda Lists
172 ;;;
173
174 (defun parse-generic-function-lambda-list (lambda-list)
175 ;; This is like PARSE-LAMBDA-LIST, but returns an additional
176 ;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword.
177 (multiple-value-bind (required optional restp rest keyp keys
178 allow-other-keys-p aux)
179 (parse-lambda-list lambda-list)
180 (values required optional restp rest keyp keys allow-other-keys-p
181 (or aux (member '&aux lambda-list :test #'eq)) aux)))
182
183 (defun check-generic-function-lambda-list (function-specifier lambda-list)
184 (multiple-value-bind (required optional restp rest keyp keys
185 allow-other-keys-p auxp aux)
186 (parse-generic-function-lambda-list lambda-list)
187 (declare (ignore restp rest keyp aux allow-other-keys-p))
188 (labels ((lambda-list-error (format-control &rest format-arguments)
189 (simple-program-error
190 (format nil _"~~@<Generic function ~a: ~?.~~@:>"
191 function-specifier
192 format-control format-arguments)))
193 (check-required-parameter (parameter)
194 (unless (symbolp parameter)
195 (lambda-list-error
196 _"Invalid generic function parameter name ~a"
197 parameter)))
198 (check-key-or-optional-parameter (parameter)
199 (unless (or (symbolp parameter)
200 (and (consp parameter)
201 (symbolp (car parameter))))
202 (lambda-list-error
203 _"Invalid generic function parameter name ~a"
204 parameter))
205 (when (and (consp parameter)
206 (not (null (cdr parameter))))
207 (lambda-list-error
208 _"Optional and key parameters of generic functions ~
209 may not have default values or supplied-p ~
210 parameters: ~<~s~>" parameter))))
211 (when auxp
212 (lambda-list-error
213 _"~s is not allowed in generic function lambda lists" '&aux))
214 (mapc #'check-required-parameter required)
215 (mapc #'check-key-or-optional-parameter optional)
216 (mapc #'check-key-or-optional-parameter keys))))
217
218 (defmacro defgeneric (function-specifier lambda-list &body options)
219 (check-generic-function-lambda-list function-specifier lambda-list)
220 (expand-defgeneric function-specifier lambda-list options))
221
222 (defun expand-defgeneric (function-specifier lambda-list options)
223 (let ((initargs ())
224 (methods ()))
225 (labels ((loose (format-control &rest format-arguments)
226 (simple-program-error
227 (format nil _"~~@<Generic function ~~s: ~?.~~@:>"
228 format-control format-arguments)
229 function-specifier))
230 (duplicate-option (name)
231 (loose _"The option ~s appears more than once" name))
232 (check-declaration (declaration-specifiers)
233 (loop for specifier in declaration-specifiers
234 when (and (consp specifier)
235 (member (car specifier)
236 '(special ftype function inline
237 notinline declaration)
238 :test #'eq)) do
239 (loose _"Declaration specifier ~s is not allowed"
240 specifier)))
241 (check-argument-precedence-order (precedence)
242 (let ((required (parse-lambda-list lambda-list)))
243 (when (set-difference required precedence)
244 (loose _"Argument precedence order must list all ~
245 required parameters and only those: ~s"
246 precedence))
247 (when (/= (length (remove-duplicates precedence))
248 (length precedence))
249 (loose _"Duplicate parameter names in argument ~
250 precedence order: ~s"
251 precedence))))
252 (initarg (key &optional (new nil new-supplied-p))
253 (if new-supplied-p
254 (setf (getf initargs key) new)
255 (getf initargs key))))
256
257 (when (and (symbolp function-specifier)
258 (special-operator-p function-specifier))
259 (loose _"Special operators cannot be made generic functions"))
260
261 (dolist (option options)
262 (case (car option)
263 (:argument-precedence-order
264 (when (initarg :argument-precedence-order)
265 (duplicate-option :argument-precedence-order))
266 (check-argument-precedence-order (cdr option))
267 (initarg :argument-precedence-order `',(cdr option)))
268 (declare
269 (check-declaration (cdr option))
270 (initarg :declarations
271 (append (cdr option) (initarg :declarations))))
272 (:documentation
273 (if (initarg :documentation)
274 (duplicate-option :documentation)
275 (initarg :documentation `',(cadr option))))
276 (:method-combination
277 (if (initarg :method-combination)
278 (duplicate-option :method-combination)
279 (initarg :method-combination `',(cdr option))))
280 (:generic-function-class
281 (if (initarg :generic-function-class)
282 (duplicate-option :generic-function-class)
283 (initarg :generic-function-class `',(cadr option))))
284 (:method-class
285 (if (initarg :method-class)
286 (duplicate-option :method-class)
287 (initarg :method-class `',(cadr option))))
288 (:method
289 (push `(push (defmethod ,function-specifier ,@(cdr option))
290 (plist-value #',function-specifier
291 'method-description-methods))
292 methods))
293 (t ;unsuported things must get a 'program-error
294 (loose _"Unsupported option ~s" option))))
295
296 (let ((declarations (initarg :declarations)))
297 (when declarations (initarg :declarations `',declarations))))
298
299 (tell-compiler-about-gf function-specifier lambda-list)
300
301 `(progn
302 (proclaim-defgeneric ',function-specifier ',lambda-list)
303 ,(make-top-level-form
304 `(defgeneric ,function-specifier)
305 '(:load-toplevel :execute)
306 `(load-defgeneric ',function-specifier ',lambda-list
307 :definition-source (c::source-location)
308 ,@initargs))
309 ,@methods
310 `,(function ,function-specifier))))
311
312 (defun load-defgeneric (function-specifier lambda-list &rest initargs)
313 ;;
314 ;; Remove methods defined by a previous DEFGENERIC (CLHS 7.6.1).
315 (when (and (fboundp function-specifier)
316 (generic-function-p (gdefinition function-specifier)))
317 (loop with gf = (gdefinition function-specifier)
318 for method in (plist-value gf 'method-description-methods) do
319 (remove-method gf method)
320 finally
321 (setf (plist-value gf 'method-description-methods) nil)))
322 ;;
323 (apply #'ensure-generic-function
324 function-specifier
325 :lambda-list lambda-list
326 initargs))
327
328
329 ;;;
330 ;;;
331 ;;;
332 (defmacro defmethod (&rest args &environment env)
333 (multiple-value-bind (name qualifiers lambda-list body)
334 (parse-defmethod args)
335 (multiple-value-bind (proto-gf proto-method)
336 (prototypes-for-make-method-lambda name)
337 (expand-defmethod name proto-gf proto-method
338 qualifiers lambda-list body env))))
339
340 (defun prototypes-for-make-method-lambda (name)
341 (if (not (eq *boot-state* 'complete))
342 (values nil nil)
343 (let ((gf? (and (fboundp name)
344 (gdefinition name))))
345 (if (or (null gf?)
346 (not (generic-function-p gf?)))
347 (values (class-prototype (find-class 'standard-generic-function))
348 (class-prototype (find-class 'standard-method)))
349 (values gf?
350 (class-prototype (or (generic-function-method-class gf?)
351 (find-class 'standard-method))))))))
352
353 ;;;
354 ;;; takes a name which is either a generic function name or a list specifying
355 ;;; a setf generic function (like: (SETF <generic-function-name>)). Returns
356 ;;; the prototype instance of the method-class for that generic function.
357 ;;;
358 ;;; If there is no generic function by that name, this returns the default
359 ;;; value, the prototype instance of the class STANDARD-METHOD. This default
360 ;;; value is also returned if the spec names an ordinary function or even a
361 ;;; macro. In effect, this leaves the signalling of the appropriate error
362 ;;; until load time.
363 ;;;
364 ;;; NOTE that during bootstrapping, this function is allowed to return NIL.
365 ;;;
366 (defun method-prototype-for-gf (name)
367 (let ((gf? (and (fboundp name)
368 (gdefinition name))))
369 (cond ((neq *boot-state* 'complete) nil)
370 ((or (null gf?)
371 (not (generic-function-p gf?))) ;Someone else MIGHT
372 ;error at load time.
373 (class-prototype (find-class 'standard-method)))
374 (t
375 (class-prototype (or (generic-function-method-class gf?)
376 (find-class 'standard-method)))))))
377
378
379 (defvar *inline-access*)
380 (defvar *method-source-info*)
381
382 (defvar *inline-methods-in-emfs* t
383 "If true, allow inlining of methods in effective methods.")
384
385 (defun expand-defmethod (name proto-gf proto-method qualifiers
386 lambda-list body env)
387 (let ((*inline-access* ()))
388 (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
389 (add-method-declarations name qualifiers lambda-list body env)
390 (let* ((auto-compile-p (auto-compile-p name qualifiers specializers))
391 (*method-source-info*
392 (when (and auto-compile-p
393 (or (null env)
394 (and (null (c::lexenv-functions env))
395 (null (c::lexenv-variables env)))))
396 (list (copy-tree body) lambda-list))))
397 (multiple-value-bind (method-function-lambda initargs)
398 (make-method-lambda proto-gf proto-method method-lambda env)
399 (when (and *inline-access*
400 auto-compile-p
401 env
402 (or (c::lexenv-functions env)
403 (c::lexenv-variables env)))
404 (setq *method-source-info* nil)
405 (warn _"~@<Defining method ~s ~s ~s using inline slot access in a ~
406 non-null lexical environment means that it cannot be ~
407 automatically recompiled.~@:>"
408 name qualifiers lambda-list))
409 (let* ((method-name `(method ,name ,@qualifiers ,specializers))
410 (initargs-form (make-method-initargs-form
411 proto-gf proto-method
412 method-function-lambda initargs env)))
413 (tell-compiler-about-gf name unspecialized-lambda-list)
414 `(progn
415 (proclaim-defgeneric ',name ',unspecialized-lambda-list)
416 ;;
417 ;; Set inlining information in the global enviroment
418 ;; for the fast function if there is an INLINE
419 ;; declaration for the method name, which is the name
420 ;; of the "slow" function. FIXME: Maybe the function
421 ;; names should be METHOD and SLOW-METHOD.
422 ,@(let ((inline (and *inline-methods-in-emfs*
423 (info function inlinep method-name))))
424 (when inline
425 (let ((fast-name (cons 'fast-method (cdr method-name)))
426 (lambda (getf (cdr initargs-form) :fast-function)))
427 `((setf (info function inlinep ',fast-name)
428 ',inline
429 (info function inline-expansion ',fast-name)
430 ',lambda)))))
431 ;;
432 ;; This expands to a LOAD-DEFMETHOD with compiled or
433 ;; interpreted lambdas for the method functions. The
434 ;; LOAD-DEFMETHOD will construct the method metaobject
435 ;; with initargs from INITARGS-FORM etc. FIXME: We
436 ;; could as well produce DEFUNs here, now that we have
437 ;; generalized function names.
438 ,(make-defmethod-form name qualifiers specializers
439 unspecialized-lambda-list
440 (if proto-method
441 (class-name (class-of proto-method))
442 'standard-method)
443 initargs-form
444 (getf (getf initargs :plist)
445 :pv-table-symbol)))))))))
446
447 (defun interned-symbol-p (x)
448 (and (symbolp x) (symbol-package x)))
449
450 (defun make-defmethod-form (name qualifiers specializers
451 unspecialized-lambda-list method-class-name
452 initargs-form &optional pv-table-symbol)
453 (let (fn fn-lambda)
454 (if (and (interned-symbol-p (if (consp name)
455 (and (eq (car name) 'setf) (cadr name))
456 name))
457 (every #'interned-symbol-p qualifiers)
458 (every (lambda (s)
459 (if (consp s)
460 (and (eq (car s) 'eql)
461 (constantp (cadr s))
462 (let ((sv (eval (cadr s))))
463 (or (interned-symbol-p sv)
464 (integerp sv)
465 (and (characterp sv)
466 (standard-char-p sv)))))
467 (interned-symbol-p s)))
468 specializers)
469 (consp initargs-form)
470 (eq (car initargs-form) 'list*)
471 (memq (cadr initargs-form) '(:function :fast-function))
472 (consp (setq fn (caddr initargs-form)))
473 (eq (car fn) 'function)
474 (consp (setq fn-lambda (cadr fn)))
475 (eq (car fn-lambda) 'lambda))
476 (let* ((specls (mapcar (lambda (specl)
477 (if (consp specl)
478 `(,(car specl) ,(eval (cadr specl)))
479 specl))
480 specializers))
481 (mname `(,(if (eq (cadr initargs-form) :function)
482 'method 'fast-method)
483 ,name ,@qualifiers ,specls)))
484 `(eval-when (:load-toplevel :execute)
485 (defun ,mname ,(cadr fn-lambda)
486 ,@(cddr fn-lambda))
487 ,(make-defmethod-form-internal
488 name qualifiers `',specls
489 unspecialized-lambda-list method-class-name
490 `(list* ,(cadr initargs-form) #',mname ,@(cdddr initargs-form))
491 pv-table-symbol)))
492 (make-top-level-form
493 `(defmethod ,name ,@qualifiers ,specializers)
494 '(:load-toplevel :execute)
495 (make-defmethod-form-internal
496 name qualifiers
497 `(list ,@(mapcar (lambda (specializer)
498 (if (consp specializer)
499 ``(,',(car specializer) ,,(cadr specializer))
500 `',specializer))
501 specializers))
502 unspecialized-lambda-list method-class-name
503 initargs-form
504 pv-table-symbol)))))
505
506 (defun make-defmethod-form-internal (name qualifiers specializers-form
507 unspecialized-lambda-list
508 method-class-name initargs-form
509 &optional pv-table-symbol)
510 `(load-defmethod
511 ',method-class-name
512 ',name
513 ',qualifiers
514 ,specializers-form
515 ',unspecialized-lambda-list
516 (list* :definition-source (c::source-location) ,initargs-form)
517 ;;Paper over a bug in KCL by passing the cache-symbol
518 ;;here in addition to in the list.
519 ',pv-table-symbol
520 ',*inline-access*
521 ',(when *inline-access* *method-source-info*)))
522
523 (defmacro make-method-function (method-lambda &environment env)
524 (make-method-function-internal method-lambda env))
525
526 (defun make-method-function-internal (method-lambda &optional env)
527 (multiple-value-bind (proto-gf proto-method)
528 (prototypes-for-make-method-lambda nil)
529 (multiple-value-bind (method-function-lambda initargs)
530 (make-method-lambda proto-gf proto-method method-lambda env)
531 (make-method-initargs-form proto-gf proto-method
532 method-function-lambda initargs env))))
533
534 (defun add-method-declarations (name qualifiers lambda-list body env)
535 (multiple-value-bind (parameters unspecialized-lambda-list specializers)
536 (parse-specialized-lambda-list lambda-list)
537 (declare (ignore parameters))
538 (multiple-value-bind (real-body declarations documentation)
539 (system:parse-body body env)
540 (values `(lambda ,unspecialized-lambda-list
541 ,@(when documentation `(,documentation))
542 (declare (method-name ,(list name qualifiers specializers)))
543 (declare (method-lambda-list ,@lambda-list))
544 ,@declarations
545 ,@real-body)
546 unspecialized-lambda-list specializers))))
547
548 #+loadable-pcl
549 (defmethod make-method-initargs-form ((proto-gf standard-generic-function)
550 (proto-mothed standard-method)
551 method-lambda initargs env)
552 (unless (eq (car-safe method-lambda) 'lambda)
553 (error _"The method-lambda argument to make-method-function, ~S,~
554 is not a lambda form" method-lambda))
555 (make-method-initargs-form-internal method-lambda initargs env))
556
557 #-loadable-pcl
558 (defun real-make-method-initargs-form (proto-gf proto-method
559 method-lambda initargs env)
560 (declare (ignore proto-gf proto-method))
561 (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
562 (error _"~@<The ~s argument to ~s, ~s, is not a lambda form.~@:>"
563 'method-lambda 'make-method-lambda method-lambda))
564 (make-method-initargs-form-internal method-lambda initargs env))
565
566 #-loadable-pcl
567 (unless (fboundp 'make-method-initargs-form)
568 (setf (gdefinition 'make-method-initargs-form)
569 (symbol-function 'real-make-method-initargs-form)))
570
571 #+loadable-pcl
572 (defmethod make-method-lambda ((proto-gf standard-generic-function)
573 (proto-method standard-method)
574 method-lambda env)
575 (make-method-lambda-internal method-lambda env))
576
577 #-loadable-pcl
578 (defun real-make-method-lambda (proto-gf proto-method method-lambda env)
579 (declare (ignore proto-gf proto-method))
580 (make-method-lambda-internal method-lambda env))
581
582 (defun get-declaration (name declarations &optional default)
583 (dolist (d declarations default)
584 (dolist (form (cdr d))
585 (when (and (consp form) (eq (car form) name))
586 (return-from get-declaration (cdr form))))))
587
588 (defun gf-key-p (gf-name)
589 (let ((info (and gf-name (info function type gf-name))))
590 (and (kernel::function-type-p info)
591 (kernel::function-type-keyp info))))
592
593 (defun make-method-lambda-internal (method-lambda &optional env)
594 (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
595 (error _"~@<The ~s argument to ~s, ~s, is not a lambda form.~@:>"
596 'method-lambda 'make-method-lambda method-lambda))
597 (multiple-value-bind (real-body declarations documentation)
598 (system:parse-body (cddr method-lambda) env)
599 (let* ((name-decl (get-declaration 'method-name declarations))
600 (sll-decl (get-declaration 'method-lambda-list declarations))
601 (method-name (when (consp name-decl) (car name-decl)))
602 (generic-function-name (when method-name (car method-name)))
603 (specialized-lambda-list (or sll-decl (cadr method-lambda))))
604 (multiple-value-bind (params lambda-list specializers)
605 (parse-specialized-lambda-list specialized-lambda-list)
606 ;;
607 (let* ((required-params
608 (loop for p in params and s in specializers collect p))
609 ;;
610 ;; Determine which of the required parameters are
611 ;; assigned to. We can't optimize slot access etc. for
612 ;; such parameters because we can't easily tell what they are
613 ;; actually bound to at each point where they are used.
614 (assigned-params
615 (let ((assigned #+nil
616 (assigned-method-params
617 method-lambda required-params env)))
618 (when assigned
619 (warn 'kernel:simple-style-warning
620 :format-control
621 _"Assignment to method parameter~p ~{~s~^, ~} ~
622 might prevent CLOS optimizations"
623 :format-arguments
624 (list (length assigned) assigned)))
625 assigned))
626 ;;
627 ;; Parameters not assigned to can be declared to be
628 ;; of their respective type, which might give some
629 ;; useful output from the compiler.
630 (class-declarations
631 (loop for p in params and s in specializers
632 when (and (symbolp s) (neq s t))
633 collect `(class ,p ,s) into decls
634 finally (return `(declare ,@decls))))
635 ;;
636 ;; Slot access etc. through parameters not assigned to
637 ;; can be optimized.
638 (optimizable-params
639 (set-difference required-params assigned-params))
640 ;;
641 (slots (mapcar #'list optimizable-params))
642 (calls (list nil))
643 (block-name (nth-value 1 (valid-function-name-p
644 generic-function-name)))
645 ;;
646 ;; Remove the documentation string and insert the
647 ;; appropriate class declarations. The documentation
648 ;; string is removed to make it easy for us to insert
649 ;; new declarations later, they will just go after the
650 ;; cadr of the method lambda. The class declarations
651 ;; are inserted to communicate the class of the method's
652 ;; arguments to the code walk.
653 (method-lambda
654 `(lambda ,lambda-list
655 (declare (ignorable ,@required-params))
656 ,class-declarations
657 ,@declarations
658 (block ,block-name
659 ,@real-body)))
660 (constant-value-p (and (null (cdr real-body))
661 (constantp (car real-body))))
662 (constant-value (and constant-value-p
663 (eval (car real-body))))
664 (plist (if (and constant-value-p
665 (or (typep constant-value
666 '(or number character))
667 (and (symbolp constant-value)
668 (symbol-package constant-value))))
669 (list :constant-value constant-value)
670 ()))
671 (applyp (dolist (p lambda-list nil)
672 (cond ((memq p '(&optional &rest &key))
673 (return t))
674 ((eq p '&aux)
675 (return nil))))))
676 (multiple-value-bind (walked-lambda call-next-method-p closurep
677 next-method-p-p)
678 ;;
679 ;; Process the method lambda, possibly optimizing forms
680 ;; appearing in it.
681 (walk-method-lambda method-lambda optimizable-params env
682 slots calls)
683 (multiple-value-bind (walked-lambda-body walked-declarations
684 walked-documentation)
685 (system:parse-body (cddr walked-lambda) env)
686 (declare (ignore walked-documentation))
687 (when (or next-method-p-p call-next-method-p)
688 (setq plist (list* :needs-next-methods-p t plist)))
689 ;;
690 ;; If slot-value, set-slot-value, slot-boundp optimizations
691 ;; have been done in WALK-METHOD-LAMBDA, wrap a PV-BINDING
692 ;; form around the lambda-body, which gives the code in
693 ;; the lambda body access to the PV table, required parameters
694 ;; and slot name lists.
695 (when (or (some #'cdr slots) (cdr calls))
696 (multiple-value-bind (slot-name-lists call-list)
697 (slot-name-lists-from-slots slots calls)
698 (let ((pv-table-symbol (make-symbol "pv-table")))
699 ;;
700 ;; PV-TABLE-SYMBOL's symbol-value is later set
701 ;; to an actual PV table for the method
702 ;; function; see INITIALIZE-METHOD-FUNCTION.
703 (setq plist
704 `(,@(when slot-name-lists
705 `(:slot-name-lists ,slot-name-lists))
706 ,@(when call-list
707 `(:call-list ,call-list))
708 :pv-table-symbol ,pv-table-symbol
709 ,@plist))
710 (setq walked-lambda-body
711 `((pv-binding (,optimizable-params ,slot-name-lists
712 ,pv-table-symbol)
713 ,@walked-lambda-body))))))
714 ;;
715 ;; When the lambda-list contains &KEY but not
716 ;; &ALLOW-OTHER-KEYS, insert an &ALLOW-OTHER-KEYS
717 ;; into the lambda-list. This corresponds to
718 ;; CLHS 7.6.4 which says that methods are effectively
719 ;; called as if :ALLOW-OTHER-KEYS T were supplied.
720 (when (and (memq '&key lambda-list)
721 (not (memq '&allow-other-keys lambda-list)))
722 (let ((aux (memq '&aux lambda-list)))
723 (setq lambda-list (nconc (ldiff lambda-list aux)
724 (list '&allow-other-keys)
725 aux))))
726 ;;
727 ;; First value is the resulting lambda. Second value
728 ;; is a list of initargs for the method instance being
729 ;; created.
730 (values `(lambda (.method-args. .next-methods.)
731 (simple-lexical-method-functions
732 (,lambda-list .method-args. .next-methods.
733 :method-name-declaration ,name-decl
734 :call-next-method-p ,call-next-method-p
735 :next-method-p-p ,next-method-p-p
736 :closurep ,closurep
737 :applyp ,applyp)
738 ,@walked-declarations
739 ,@walked-lambda-body))
740 `(,@(when plist
741 `(:plist ,plist))
742 ,@(when documentation
743 `(:documentation ,documentation)))))))))))
744
745 #-loadable-pcl
746 (unless (fboundp 'make-method-lambda)
747 (setf (gdefinition 'make-method-lambda)
748 (symbol-function 'real-make-method-lambda)))
749
750 (defmacro simple-lexical-method-functions
751 ((lambda-list method-args next-methods &rest lmf-options)
752 &body body)
753 `(let ((,method-args ,method-args)
754 (,next-methods ,next-methods))
755 (declare (ignorable ,method-args ,next-methods))
756 (bind-simple-lexical-method-macros (,method-args ,next-methods)
757 (bind-lexical-method-functions (,@lmf-options)
758 (bind-args (,lambda-list ,method-args)
759 ,@body)))))
760
761 (defmacro fast-lexical-method-functions
762 ((lambda-list next-method-call args rest-arg &rest lmf-options)
763 &body body)
764 `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
765 (bind-lexical-method-functions (,@lmf-options)
766 (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
767 ,@body))))
768
769 (defun call-no-next-method (method-name-declaration &rest args)
770 (destructuring-bind (name qualifiers specializers)
771 (car method-name-declaration)
772 (let ((method (find-method (gdefinition name) qualifiers specializers)))
773 (apply #'no-next-method (method-generic-function method) method args))))
774
775 (defmacro bind-simple-lexical-method-macros ((method-args next-methods)
776 &body body)
777 `(macrolet ((call-next-method-bind (&body body)
778 `(let ((.next-method. (car ,',next-methods))
779 (,',next-methods (cdr ,',next-methods)))
780 (declare (ignorable .next-method. ,',next-methods))
781 ,@body))
782 (with-rebound-original-arguments ((cnm-p) &body body)
783 (declare (ignore cnm-p))
784 `(let () ,@body))
785 (check-cnm-args-body (method-name-declaration cnm-args)
786 `(%check-cnm-args ,cnm-args ,',method-args
787 ',method-name-declaration))
788 (call-next-method-body (method-name-declaration cnm-args)
789 `(if .next-method.
790 (funcall (if (std-instance-p .next-method.)
791 (method-function .next-method.)
792 .next-method.) ; for early methods
793 (or ,cnm-args ,',method-args)
794 ,',next-methods)
795 (apply #'call-no-next-method ',method-name-declaration
796 (or ,cnm-args ,',method-args))))
797 (next-method-p-body ()
798 `(not (null .next-method.))))
799 ,@body))
800
801 (defstruct method-call
802 (function #'identity :type function)
803 call-method-args)
804
805 (declaim (freeze-type method-call))
806
807 (defmacro invoke-method-call1 (function args cm-args)
808 `(let ((.function. ,function)
809 (.args. ,args)
810 (.cm-args. ,cm-args))
811 (if (and .cm-args. (null (cdr .cm-args.)))
812 (funcall (the function .function.) .args. (car .cm-args.))
813 (apply (the function .function.) .args. .cm-args.))))
814
815 (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
816 `(invoke-method-call1 (method-call-function ,method-call)
817 ,(if restp
818 `(list* ,@required-args+rest-arg)
819 `(list ,@required-args+rest-arg))
820 (method-call-call-method-args ,method-call)))
821
822 (defstruct fast-method-call
823 (function #'identity :type function)
824 pv-cell
825 next-method-call
826 arg-info)
827
828 (declaim (freeze-type fast-method-call))
829
830 (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
831 `(function-funcall (fast-method-call-function ,method-call)
832 (fast-method-call-pv-cell ,method-call)
833 (fast-method-call-next-method-call ,method-call)
834 ,@required-args+rest-arg))
835
836 (defstruct fast-instance-boundp
837 (index 0 :type fixnum))
838
839 (declaim (freeze-type fast-instance-boundp))
840
841 (defmacro invoke-effective-method-function-fast
842 (emf restp &rest required-args+rest-arg)
843 (declare (ignore restp))
844 `(progn
845 (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
846
847 (defmacro invoke-effective-method-function
848 (emf restp &rest required-args+rest-arg)
849 (assert (constantp restp))
850 (setq restp (eval restp))
851 `(progn
852 (etypecase ,emf
853 (fast-method-call
854 (invoke-fast-method-call ,emf ,@required-args+rest-arg))
855 ;;
856 ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
857 `((fixnum
858 (let* ((.slots. (get-slots-or-nil
859 ,(car required-args+rest-arg)))
860 (value (when .slots. (%slot-ref .slots. ,emf))))
861 (if (eq value +slot-unbound+)
862 (slot-unbound-internal ,(car required-args+rest-arg) ,emf)
863 value)))))
864 ;;
865 ;; This generates code in innocent methods that Python can
866 ;; prove not to succeed, for example:
867 ;;
868 ;; (defclass foo () ())
869 ;;
870 ;; (defmethod foo3 ((x foo) y)
871 ;; (format y "Its methods are:~%")
872 ;; (call-next-method))
873 ;;
874 ;; The CALL-NEXT-METHOD contains an INVOKE-EFFECTIVE-M-F. From
875 ;; the use of Y in FORMAT, Python deduces what Y can be at the
876 ;; point of the INVOKE-EFFECTIVE-METHOD-FUNCTION, namely (OR
877 ;; (MEMBER NIL T) FUNCTION), and that's not something for which
878 ;; the code below is known to succeed. So, it prints a note.
879 ;;
880 ;; Since the user can't do much about this, and we can't
881 ;; either, without tremendous effort, let's suppress warnings
882 ;; here.
883 ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
884 (destructuring-bind (new-value object) required-args+rest-arg
885 `((fixnum
886 (locally
887 (declare (optimize (ext:inhibit-warnings 3)))
888 (setf (%slot-ref (get-slots-or-nil ,object) ,emf)
889 ,new-value))))))
890 ;;
891 (method-call
892 (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
893 (function
894 ,(if restp
895 `(apply (the function ,emf) ,@required-args+rest-arg)
896 `(funcall (the function ,emf) ,@required-args+rest-arg))))))
897
898 (defun invoke-emf (emf args)
899 (etypecase emf
900 (fast-method-call
901 (let* ((arg-info (fast-method-call-arg-info emf))
902 (restp (cdr arg-info))
903 (nreq (car arg-info)))
904 (if restp
905 (let* ((rest-args (nthcdr nreq args))
906 (req-args (ldiff args rest-args)))
907 (apply (fast-method-call-function emf)
908 (fast-method-call-pv-cell emf)
909 (fast-method-call-next-method-call emf)
910 (nconc req-args (list rest-args))))
911 (cond ((null args)
912 (if (eql nreq 0)
913 (invoke-fast-method-call emf)
914 (internal-program-error emf _"Wrong number of args.")))
915 ((null (cdr args))
916 (if (eql nreq 1)
917 (invoke-fast-method-call emf (car args))
918 (internal-program-error emf _"Wrong number of args.")))
919 ((null (cddr args))
920 (if (eql nreq 2)
921 (invoke-fast-method-call emf (car args) (cadr args))
922 (internal-program-error emf _"Wrong number of args.")))
923 (t
924 (apply (fast-method-call-function emf)
925 (fast-method-call-pv-cell emf)
926 (fast-method-call-next-method-call emf)
927 args))))))
928 (method-call
929 (apply (method-call-function emf)
930 args
931 (method-call-call-method-args emf)))
932 (fixnum
933 (cond ((null args)
934 (internal-program-error emf _"1 or 2 args expected."))
935 ((null (cdr args))
936 (let ((value (%slot-ref (get-slots (car args)) emf)))
937 (if (eq value +slot-unbound+)
938 (slot-unbound-internal (car args) emf)
939 value)))
940 ((null (cddr args))
941 (setf (%slot-ref (get-slots (cadr args)) emf)
942 (car args)))
943 (t
944 (internal-program-error emf _"1 or 2 args expected."))))
945 (fast-instance-boundp
946 (if (or (null args) (cdr args))
947 (internal-program-error emf _"1 arg expected.")
948 (not (eq (%slot-ref (get-slots (car args))
949 (fast-instance-boundp-index emf))
950 +slot-unbound+))))
951 (function
952 (apply emf args))))
953
954 (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
955 &body body)
956 (let* ((all-params (append args (when rest-arg `(,rest-arg))))
957 (bindings (mapcar (lambda (x) `(,x ,x)) all-params)))
958 `(macrolet ((call-next-method-bind (&body body)
959 `(let () ,@body))
960 ;;
961 ;; Rebind method parameters around BODY if CNM-P is true.
962 ;; CNM-P true means there is a CALL-NEXT-METHOD in BODY.
963 ;;
964 ;; The problem with rebinding parameters is that this
965 ;; can use parameters that are declared to be ignored
966 ;; in the method body, leading to spurious warnings.
967 ;; For now, we deal with this by translating IGNORE to
968 ;; IGNORABLE.
969 (with-rebound-original-arguments ((cnm-p) &body body)
970 (if cnm-p
971 `(let ,',bindings
972 (declare (ignorable ,@',all-params))
973 ,@body)
974 `(let () ,@body)))
975 ;;
976 (check-cnm-args-body (method-name-declaration cnm-args)
977 `(%check-cnm-args ,cnm-args (list ,@',args)
978 ',method-name-declaration))
979 ;;
980 (call-next-method-body (method-name-declaration cnm-args)
981 `(if ,',next-method-call
982 ,(if (and (null ',rest-arg)
983 (consp cnm-args)
984 (eq (car cnm-args) 'list))
985 `(invoke-effective-method-function
986 ,',next-method-call nil
987 ,@(cdr cnm-args))
988 (let ((call `(invoke-effective-method-function
989 ,',next-method-call
990 ,',(not (null rest-arg))
991 ,@',args
992 ,@',(when rest-arg `(,rest-arg)))))
993 `(if ,cnm-args
994 (bind-args ((,@',args ,@',(when rest-arg
995 `(&rest ,rest-arg)))
996 ,cnm-args)
997 ,call)
998 ,call)))
999 ,(if (and (null ',rest-arg)
1000 (consp cnm-args)
1001 (eq (car cnm-args) 'list))
1002 `(call-no-next-method ',method-name-declaration
1003 ,@(cdr cnm-args))
1004 `(call-no-next-method ',method-name-declaration
1005 ,@',args
1006 ,@',(when rest-arg
1007 `(,rest-arg))))))
1008 (next-method-p-body ()
1009 `(not (null ,',next-method-call))))
1010 ,@body)))
1011
1012 (defmacro bind-lexical-method-functions
1013 ((&key call-next-method-p next-method-p-p closurep applyp
1014 method-name-declaration)
1015 &body body)
1016 (declare (ignore next-method-p-p closurep applyp))
1017 `(call-next-method-bind
1018 (flet ((call-next-method (&rest cnm-args)
1019 (check-cnm-args-body ,method-name-declaration cnm-args)
1020 (call-next-method-body ,method-name-declaration cnm-args))
1021 (next-method-p ()
1022 (next-method-p-body)))
1023 (declare (ignorable #'call-next-method #'next-method-p))
1024 (with-rebound-original-arguments (,call-next-method-p)
1025 ,@body))))
1026
1027 ;;;
1028 ;;; The standard says it's an error if CALL-NEXT-METHOD is called with
1029 ;;; arguments, and the set of methods applicable to those arguments is
1030 ;;; different from the set of methods applicable to the original
1031 ;;; method arguments. (According to Barry Margolin, this rule was
1032 ;;; probably added to ensure that before and around methods are always
1033 ;;; run before primary methods.)
1034 ;;;
1035 ;;; This could be optimized for the case that the generic function
1036 ;;; doesn't have hairy methods, does have standard method combination,
1037 ;;; is a standard generic function, there are no methods defined on it
1038 ;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such
1039 ;;; preconditions. That looks hairy and is probably not worth it,
1040 ;;; because this check will never be fast.
1041 ;;;
1042 (defun %check-cnm-args (cnm-args orig-args method-name-declaration)
1043 (when cnm-args
1044 (let* ((gf (fdefinition (caar method-name-declaration)))
1045 (omethods (compute-applicable-methods gf orig-args))
1046 (nmethods (compute-applicable-methods gf cnm-args)))
1047 (unless (equal omethods nmethods)
1048 (error _"~@<The set of methods ~s applicable to argument~p ~
1049 ~{~s~^, ~} to call-next-method is different from ~
1050 the set of methods ~s applicable to the original ~
1051 method argument~p ~{~s~^, ~}.~@:>"
1052 nmethods (length cnm-args) cnm-args omethods
1053 (length orig-args) orig-args)))))
1054
1055 ;;;
1056 ;;; Remove the above check, unless in safe code.
1057 ;;;
1058 (in-package :c)
1059
1060 (defknown pcl::%check-cnm-args (t t t) t
1061 (movable foldable flushable))
1062
1063 (deftransform pcl::%check-cnm-args ((x y z) (t t t) t :policy (< safety 3))
1064 nil)
1065
1066 (in-package :pcl)
1067
1068 (defun too-many-args ()
1069 (simple-program-error _"Too many arguments."))
1070
1071 (declaim (inline get-key-arg))
1072 (defun get-key-arg (keyword list)
1073 (car (get-key-arg1 keyword list)))
1074
1075 (defun get-key-arg1 (keyword list)
1076 (loop for (key . more) on list by #'cddr
1077 when (eq key keyword) return more))
1078
1079 (defmacro bind-args ((lambda-list args) &body body)
1080 (let ((state 'required))
1081 (collect ((bindings) (ignorable (list '.args.)))
1082 (dolist (var lambda-list)
1083 (if (memq var lambda-list-keywords)
1084 (ecase var
1085 ((&optional &key &rest &aux)
1086 (setq state var))
1087 (&allow-other-keys))
1088 (case state
1089 (required
1090 (bindings `(,var (pop .args.))))
1091 (&optional
1092 (etypecase var
1093 (symbol
1094 (bindings `(,var (when .args. (pop .args.)))))
1095 (cons
1096 (destructuring-bind (var &optional default
1097 (supplied nil supplied-p))
1098 var
1099 (when supplied-p (bindings `(,supplied .args.)))
1100 (bindings `(,var (if .args. (pop .args.) ,default)))))))
1101 (&rest
1102 (bindings `(,var .args.)))
1103 (&key
1104 (etypecase var
1105 (symbol
1106 (bindings `(,var (get-key-arg ,(make-keyword var) .args.))))
1107 (cons
1108 (destructuring-bind (var &optional default
1109 (supplied nil supplied-p))
1110 var
1111 (multiple-value-bind (key var)
1112 (if (consp var)
1113 (destructuring-bind (key var) var
1114 (values key var))
1115 (values (make-keyword var) var))
1116 (bindings `(.key. (get-key-arg1 ',key .args.)))
1117 (when supplied-p (bindings `(,supplied .key.)))
1118 (bindings `(,var (if .key. (car .key.) ,default))))))))
1119 (&aux
1120 (bindings var)))))
1121 (when (eq state '&optional)
1122 (bindings '(.dummy. (unless (null .args.) (too-many-args))))
1123 (ignorable '.dummy.))
1124 `(let* ((.args. ,args) ,@(bindings))
1125 (declare (ignorable ,@(ignorable)))
1126 ,@body))))
1127
1128 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
1129 (let ((call-next-method-p nil) ;flag indicating that call-next-method
1130 ;should be in the method definition
1131 (closurep nil) ;flag indicating that #'call-next-method
1132 ;was seen in the body of a method
1133 (next-method-p-p nil)) ;flag indicating that next-method-p
1134 ;should be in the method definition
1135 (flet ((walk-function (form context env)
1136 (cond ((not (eq context :eval))
1137 form)
1138 ((not (listp form))
1139 form)
1140 ((eq (car form) 'call-next-method)
1141 (setq call-next-method-p t)
1142 form)
1143 ((eq (car form) 'next-method-p)
1144 (setq next-method-p-p t)
1145 form)
1146 ((and (eq (car form) 'function)
1147 (cond ((eq (cadr form) 'call-next-method)
1148 (setq call-next-method-p t)
1149 (setq closurep t)
1150 form)
1151 ((eq (cadr form) 'next-method-p)
1152 (setq next-method-p-p t)
1153 (setq closurep t)
1154 form)
1155 (t nil))))
1156 ;;
1157 ((and (memq (car form)
1158 '(slot-value slot-boundp set-slot-value))
1159 (constantp (caddr form)))
1160 (optimize-slot-access form env required-parameters slots))
1161 ;;
1162 ((and (eq (car form) 'apply)
1163 (consp (cadr form))
1164 (eq (car (cadr form)) 'function)
1165 (info-gf-name-p (cadr (cadr form))))
1166 (optimize-gf-call form required-parameters calls env))
1167 ;;
1168 ((and (symbolp (car form))
1169 (null (cddr form))
1170 (info-accessor-p (car form)))
1171 (optimize-slot-reader form required-parameters slots env))
1172 ;;
1173 ((and (eq (car form) 'setf)
1174 (consp (cadr form))
1175 (= (length form) 3)
1176 (= (length (cadr form)) 2)
1177 (info-accessor-p `(setf ,(caadr form))))
1178 (optimize-slot-writer form required-parameters slots env))
1179 ;;
1180 ((and (valid-function-name-p (car form))
1181 (info-gf-name-p (car form))
1182 (not (walker::environment-function env (car form))))
1183 (optimize-gf-call form required-parameters calls env))
1184 (t
1185 form))))
1186
1187 (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
1188 (values walked-lambda
1189 call-next-method-p closurep next-method-p-p)))))
1190
1191 ;;;
1192 ;;; If VAR is the name of a required method parameter in
1193 ;;; REQUIRED-PARAMS, or a variable rebinding of such a parameter in
1194 ;;; lexical environment ENV, or a form (THE ... <param>) for such a
1195 ;;; parameter, return the method parameter's name. Otherwise return
1196 ;;; NIL.
1197 ;;;
1198 (defun method-parameter (var required-params env)
1199 (let ((var (if (eq (car-safe var) 'the) (third var) var)))
1200 (when (symbolp var)
1201 (let* ((vr (caddr (variable-declaration 'variable-rebinding var env)))
1202 (var (or vr var))
1203 (param (car (memq var required-params))))
1204 ;;
1205 ;; (defmethod foo ((class integer))
1206 ;; (flet ((bar ()
1207 ;; (loop for class in (reverse class) do
1208 ;; (print class))))
1209 ;; (bar)))
1210 ;;
1211 ;; results in two lexical vars being recorded in env inside
1212 ;; the flet/loop, one for the method parameter, and one from
1213 ;; a let generated by the loop.
1214 (when param
1215 (let ((lexvars (walker::env-lexical-variables env)))
1216 (when (= (count var lexvars :key #'car) 1)
1217 param)))))))
1218
1219 ;;;
1220 ;;; Return a list of those parameters from REQUIRED-PARAMS which
1221 ;;; are assigned to in METHOD-LAMBDA.
1222 ;;;
1223 (defun assigned-method-params (method-lambda required-params env)
1224 (let ((assigned-params ()))
1225 (flet ((walk (form context env)
1226 (when (and (eq context :eval)
1227 (memq (car-safe form) '(setq setf)))
1228 (loop for var in (cdr form) by #'cddr
1229 as param = (method-parameter var required-params env)
1230 when param do
1231 (pushnew param assigned-params)))
1232 form))
1233 (walk-form method-lambda env #'walk)
1234 assigned-params)))
1235
1236 (defun generic-function-name-p (name)
1237 (and (valid-function-name-p name)
1238 (fboundp name)
1239 (if (eq *boot-state* 'complete)
1240 (standard-generic-function-p (gdefinition name))
1241 (funcallable-instance-p (gdefinition name)))))
1242
1243
1244
1245 (defvar *method-function-plist* (make-hash-table :test 'eq))
1246 (defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil)
1247 (defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil)
1248
1249 (defun method-function-plist (method-function)
1250 (unless (eq method-function *mf1*)
1251 (rotatef *mf1* *mf2*)
1252 (rotatef *mf1p* *mf2p*)
1253 (rotatef *mf1cp* *mf2cp*))
1254 (unless (or (eq method-function *mf1*) (null *mf1cp*))
1255 (setf (gethash *mf1* *method-function-plist*) *mf1p*))
1256 (unless (eq method-function *mf1*)
1257 (setf *mf1* method-function
1258 *mf1cp* nil
1259 *mf1p* (gethash method-function *method-function-plist*)))
1260 *mf1p*)
1261
1262 (defun (setf method-function-plist)
1263 (val method-function)
1264 (unless (eq method-function *mf1*)
1265 (rotatef *mf1* *mf2*)
1266 (rotatef *mf1cp* *mf2cp*)
1267 (rotatef *mf1p* *mf2p*))
1268 (unless (or (eq method-function *mf1*) (null *mf1cp*))
1269 (setf (gethash *mf1* *method-function-plist*) *mf1p*))
1270 (setf *mf1* method-function
1271 *mf1cp* t
1272 *mf1p* val))
1273
1274 (defun method-function-get (method-function key &optional default)
1275 (getf (method-function-plist method-function) key default))
1276
1277 (defun (setf method-function-get)
1278 (val method-function key)
1279 (setf (getf (method-function-plist method-function) key) val))
1280
1281 (defun method-function-pv-table (method-function)
1282 (method-function-get method-function :pv-table))
1283
1284 (defun method-function-method (method-function)
1285 (method-function-get method-function :method))
1286
1287 (defun method-function-needs-next-methods-p (method-function)
1288 (method-function-get method-function :needs-next-methods-p t))
1289
1290 ;;;
1291 ;;; Return a method function name of METHOD. If FAST-FUNCTION
1292 ;;; is true, return the fast method function name, otherwise
1293 ;;; return the slow method function name.
1294 ;;;
1295 (defun method-function-name (method &optional (fast-function t))
1296 (let ((fn (slot-value method
1297 (if fast-function 'fast-function 'function))))
1298 (assert (functionp fn))
1299 (method-function-get fn :name)))
1300
1301
1302 (defun load-defmethod (class name quals specls ll initargs
1303 &optional pv-table-symbol inline-access
1304 method-info)
1305 (setq initargs (copy-tree initargs))
1306 (let ((method-spec (or (getf initargs :method-spec)
1307 (make-method-spec name quals specls))))
1308 (setf (getf initargs :method-spec) method-spec)
1309 (load-defmethod-internal class name quals specls ll initargs
1310 pv-table-symbol inline-access
1311 method-info)))
1312
1313 (defvar *compile-interpreted-methods-p* t
1314 "When true, compile interpreted method functions.")
1315
1316 (defun load-defmethod-internal
1317 (method-class gf-name qualifiers specializers lambda-list
1318 initargs pv-table-symbol inline-access method-info)
1319 (when pv-table-symbol
1320 (setf (getf (getf initargs :plist) :pv-table-symbol)
1321 pv-table-symbol))
1322 ;;
1323 ;; Optionally compile method functions if they are interpreted.
1324 (when *compile-interpreted-methods-p*
1325 (flet ((maybe-compile (key)
1326 (let ((fn (getf initargs key)))
1327 (when (and (eval:interpreted-function-p fn)
1328 ;; Can't compile closures.
1329 (null (eval:interpreted-function-closure fn)))
1330 (let* ((type (ecase key
1331 (:fast-function 'fast-method)
1332 (:function 'method)))
1333 (name `(,type ,gf-name ,@qualifiers ,specializers)))
1334 (compile name fn)
1335 (setf (getf initargs key) (fdefinition name)))))))
1336 (maybe-compile :fast-function)
1337 (maybe-compile :function)))
1338 ;;
1339 (let ((method (apply #'add-named-method
1340 gf-name qualifiers specializers lambda-list initargs)))
1341 ;;
1342 (record-inline-access-info method inline-access method-info)
1343 ;;
1344 (unless (or (eq method-class 'standard-method)
1345 (eq (find-class method-class nil) (class-of method)))
1346 (format *error-output*
1347 _"~&~@<At the time the method with qualifiers ~S and ~
1348 specializers ~S on the generic function ~S ~
1349 was compiled, the method class for that generic function was ~
1350 ~S. But, the method class is now ~S, this ~
1351 may mean that this method was compiled improperly.~@:>"
1352 qualifiers specializers gf-name
1353 method-class (class-name (class-of method))))
1354 method))
1355
1356 (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
1357 `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
1358
1359 (defun initialize-method-function (initargs &optional return-function-p method)
1360 (let* ((mf (getf initargs :function))
1361 (method-spec (getf initargs :method-spec))
1362 (plist (getf initargs :plist))
1363 (pv-table-symbol (getf plist :pv-table-symbol))
1364 (pv-table nil)
1365 (mff (getf initargs :fast-function)))
1366 (flet ((set-mf-property (p v)
1367 (when mf
1368 (setf (method-function-get mf p) v))
1369 (when mff
1370 (setf (method-function-get mff p) v))))
1371 (when method-spec
1372 (when mf
1373 (setq mf (set-function-name mf method-spec)))
1374 (when mff
1375 (let ((name (cons 'fast-method (cdr method-spec))))
1376 (set-function-name mff name)
1377 (unless mf
1378 (set-mf-property :name name)))))
1379 (when plist
1380 (let ((snl (getf plist :slot-name-lists))
1381 (cl (getf plist :call-list)))
1382 (when (or snl cl)
1383 (setq pv-table (intern-pv-table :slot-name-lists snl
1384 :call-list cl))
1385 (when pv-table (set pv-table-symbol pv-table))
1386 (set-mf-property :pv-table pv-table)))
1387 (loop (when (null plist) (return nil))
1388 (set-mf-property (pop plist) (pop plist)))
1389 (when method
1390 (set-mf-property :method method))
1391 (when return-function-p
1392 (or mf (method-function-from-fast-function mff)))))))
1393
1394
1395
1396 (defun analyze-lambda-list (lambda-list)
1397 (multiple-value-bind (required optional restp rest keyp keys
1398 allow-other-keys-p aux)
1399 (parse-lambda-list lambda-list t)
1400 (declare (ignore rest aux))
1401 (flet ((keyword-parameter-keyword (x)
1402 (let ((key (if (atom x) x (car x))))
1403 (if (atom key)
1404 (make-keyword key)
1405 (car key)))))
1406 (values (length required) (length optional)
1407 keyp restp allow-other-keys-p
1408 (mapcar #'keyword-parameter-keyword keys)
1409 keys))))
1410
1411 (defun ftype-declaration-from-lambda-list (lambda-list name)
1412 (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
1413 keywords keyword-parameters)
1414 (analyze-lambda-list lambda-list)
1415 (declare (ignore keyword-parameters))
1416 (let* ((old (c::info function type name))
1417 (old-ftype (if (c::function-type-p old) old nil))
1418 (old-restp (and old-ftype (c::function-type-rest old-ftype)))
1419 (old-keys (and old-ftype
1420 (mapcar #'c::key-info-name
1421 (c::function-type-keywords old-ftype))))
1422 (old-keysp (and old-ftype (c::function-type-keyp old-ftype)))
1423 (old-allowp (and old-ftype (c::function-type-allowp old-ftype)))
1424 (keywords (union old-keys keywords)))
1425 `(function ,(append (make-list nrequired :initial-element t)
1426 (when (plusp noptional)
1427 (append '(&optional)
1428 (make-list noptional :initial-element t)))
1429 (when (or restp old-restp)
1430 '(&rest t))
1431 (when (or keysp old-keysp)
1432 (append '(&key)
1433 (mapcar (lambda (key)
1434 `(,key t))
1435 keywords)
1436 (when (or allow-other-keys-p old-allowp)
1437 '(&allow-other-keys)))))
1438 *))))
1439
1440 (defun proclaim-defgeneric (spec lambda-list)
1441 (let ((decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec)
1442 ,spec)))
1443 (set-gf-info spec lambda-list)
1444 (proclaim decl)))
1445
1446 ;;;; Early generic-function support
1447 ;;;
1448 ;;;
1449 (defvar *early-generic-functions* ())
1450
1451 (defun ensure-generic-function (function-specifier
1452 &rest all-keys
1453 &key environment
1454 &allow-other-keys)
1455 (declare (ignore environment))
1456 (let ((existing (and (fboundp function-specifier)
1457 (gdefinition function-specifier))))
1458 (when (and existing
1459 (eq *boot-state* 'complete)
1460 (null (generic-function-p existing)))
1461 (generic-clobbers-function function-specifier)
1462 (setq existing nil))
1463 (apply #'ensure-generic-function-using-class
1464 existing function-specifier all-keys)))
1465
1466 (defun generic-clobbers-function (function-specifier)
1467 (restart-case
1468 (simple-program-error
1469 _"~@<~S already names an ordinary function or a macro. ~
1470 If you want to replace it with a generic function, you should remove ~
1471 the existing definition beforehand.~@:>"
1472 function-specifier)
1473 (continue ()
1474 :report (lambda (stream)
1475 (format stream _"~@<Discard the existing definition of ~S.~@:>"
1476 function-specifier))
1477 (fmakunbound function-specifier))))
1478
1479 (defvar *sgf-wrapper*
1480 (boot-make-wrapper (early-class-size 'standard-generic-function)
1481 'standard-generic-function))
1482
1483 (defvar *sgf-slots-init*
1484 (mapcar (lambda (canonical-slot)
1485 (if (memq (getf canonical-slot :name) '(arg-info source))
1486 +slot-unbound+
1487 (let ((initfunction (getf canonical-slot :initfunction)))
1488 (if initfunction
1489 (funcall initfunction)
1490 +slot-unbound+))))
1491 (early-collect-inheritance 'standard-generic-function)))
1492
1493 (defvar *sgf-method-class-index*
1494 (bootstrap-slot-index 'standard-generic-function 'method-class))
1495
1496 (defun early-gf-p (x)
1497 (and (fsc-instance-p x)
1498 (eq (slot-ref (get-slots x) *sgf-method-class-index*)
1499 +slot-unbound+)))
1500
1501 (defvar *sgf-methods-index*
1502 (bootstrap-slot-index 'standard-generic-function 'methods))
1503
1504 (defmacro early-gf-methods (gf)
1505 `(slot-ref (get-slots ,gf) *sgf-methods-index*))
1506
1507 (defvar *sgf-arg-info-index*
1508 (bootstrap-slot-index 'standard-generic-function 'arg-info))
1509
1510 (defmacro early-gf-arg-info (gf)
1511 `(slot-ref (get-slots ,gf) *sgf-arg-info-index*))
1512
1513 (defvar *sgf-dfun-state-index*
1514 (bootstrap-slot-index 'standard-generic-function 'dfun-state))
1515
1516 (defstruct (arg-info
1517 (:conc-name nil)
1518 (:constructor make-arg-info ()))
1519 (arg-info-lambda-list :no-lambda-list)
1520 arg-info-precedence
1521 arg-info-metatypes
1522 arg-info-number-optional
1523 arg-info-key/rest-p
1524 arg-info-keywords ;nil no keyword or rest allowed
1525 ;(k1 k2 ..) each method must accept these keyword arguments
1526 ;T must have &key or &rest
1527
1528 gf-info-simple-accessor-type ; nil, reader, writer, boundp
1529 (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
1530
1531 gf-info-static-c-a-m-emf
1532 (gf-info-c-a-m-emf-std-p t)
1533 gf-info-fast-mf-p)
1534
1535 (declaim (freeze-type arg-info))
1536
1537 (defun arg-info-valid-p (arg-info)
1538 (not (null (arg-info-number-optional arg-info))))
1539
1540 (defun arg-info-applyp (arg-info)
1541 (or (plusp (arg-info-number-optional arg-info))
1542 (arg-info-key/rest-p arg-info)))
1543
1544 (defun arg-info-number-required (arg-info)
1545 (length (arg-info-metatypes arg-info)))
1546
1547 (defun arg-info-nkeys (arg-info)
1548 (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
1549
1550 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
1551 argument-precedence-order)
1552 (let* ((arg-info (if (eq *boot-state* 'complete)
1553 (gf-arg-info gf)
1554 (early-gf-arg-info gf)))
1555 (methods (if (eq *boot-state* 'complete)
1556 (generic-function-methods gf)
1557 (early-gf-methods gf)))
1558 (was-valid-p (integerp (arg-info-number-optional arg-info)))
1559 (first-p (and new-method (null (cdr methods)))))
1560 (when (and (not lambda-list-p) methods)
1561 (setq lambda-list (gf-lambda-list gf)))
1562 (when (or lambda-list-p
1563 (and first-p (eq (arg-info-lambda-list arg-info) :no-lambda-list)))
1564 (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1565 (analyze-lambda-list lambda-list)
1566 (when (and methods (not first-p))
1567 (let ((gf-nreq (arg-info-number-required arg-info))
1568 (gf-nopt (arg-info-number-optional arg-info))
1569 (gf-key/rest-p (arg-info-key/rest-p arg-info)))
1570 (unless (and (= nreq gf-nreq)
1571 (= nopt gf-nopt)
1572 (eq (or keysp restp) gf-key/rest-p))
1573 (error _"~@<The lambda-list ~S is incompatible with ~
1574 existing methods of ~S.~@:>"
1575 lambda-list gf))))
1576 (when lambda-list-p
1577 (setf (arg-info-lambda-list arg-info) lambda-list))
1578 (when (or lambda-list-p argument-precedence-order
1579 (null (arg-info-precedence arg-info)))
1580 (setf (arg-info-precedence arg-info)
1581 (compute-precedence lambda-list nreq
1582 argument-precedence-order)))
1583 (setf (arg-info-metatypes arg-info) (make-list nreq))
1584 (setf (arg-info-number-optional arg-info) nopt)
1585 (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
1586 (setf (arg-info-keywords arg-info)
1587 (if lambda-list-p
1588 (if allow-other-keys-p t keywords)
1589 (arg-info-key/rest-p arg-info)))))
1590 (when new-method
1591 (check-method-arg-info gf arg-info new-method))
1592 (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
1593 arg-info))
1594
1595 (declaim (inline generic-function-name*))
1596 (defun generic-function-name* (gf)
1597 (if (early-gf-p gf)
1598 (early-gf-name gf)
1599 (generic-function-name gf)))
1600
1601 (declaim (inline generic-function-methods*))
1602 (defun generic-function-methods* (gf)
1603 (if (early-gf-p gf)
1604 (early-gf-methods gf)
1605 (generic-function-methods gf)))
1606
1607 (declaim (inline gf-arg-info*))
1608 (defun gf-arg-info* (gf)
1609 (if (early-gf-p gf)
1610 (early-gf-arg-info gf)
1611 (gf-arg-info gf)))
1612
1613 (declaim (inline method-lambda-list*))
1614 (defun method-lambda-list* (method)
1615 (if (consp method)
1616 (early-method-lambda-list method)
1617 (method-lambda-list method)))
1618
1619 (defun compute-precedence (lambda-list nreq argument-precedence-order)
1620 (if (null argument-precedence-order)
1621 (let ((list nil))
1622 (dotimes (i nreq list)
1623 (declare (fixnum i))
1624 (push (- (1- nreq) i) list)))
1625 (mapcar (lambda (x) (position x lambda-list))
1626 argument-precedence-order)))
1627
1628 (defun check-method-arg-info (gf arg-info method)
1629 (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1630 (analyze-lambda-list (method-lambda-list* method))
1631 (flet ((lose (format-control &rest format-args)
1632 (simple-program-error
1633 (format nil _"~~@<Attempt to add the method ~~S to the generic ~
1634 function ~~S, but ~?.~~@:>"
1635 format-control format-args)
1636 method gf))
1637 (compare (x y)
1638 (if (> x y) _"more" _"fewer")))
1639 (let ((gf-nreq (arg-info-number-required arg-info))
1640 (gf-nopt (arg-info-number-optional arg-info))
1641 (gf-key/rest-p (arg-info-key/rest-p arg-info))
1642 (gf-keywords (arg-info-keywords arg-info)))
1643 (unless (= nreq gf-nreq)
1644 (lose _"the method has ~A required arguments than the ~
1645 generic function"
1646 (compare nreq gf-nreq)))
1647 (unless (= nopt gf-nopt)
1648 (lose _"the method has ~S optional arguments than the ~
1649 generic function"
1650 (compare nopt gf-nopt)))
1651 (unless (eq (or keysp restp) gf-key/rest-p)
1652 (lose _"the method and generic function differ in whether ~
1653 they accept rest or keyword arguments"))
1654 (when (consp gf-keywords)
1655 (unless (or (and restp (not keysp))
1656 allow-other-keys-p
1657 (every (lambda (k) (memq k keywords)) gf-keywords))
1658 (lose _"the method does not accept each of the keyword ~
1659 arguments ~S"
1660 gf-keywords)))))))
1661
1662 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
1663 (let* ((existing-p (and methods (cdr methods) new-method))
1664 (nreq (length (arg-info-metatypes arg-info)))
1665 (metatypes (if existing-p
1666 (arg-info-metatypes arg-info)
1667 (make-list nreq)))
1668 (type (if existing-p
1669 (gf-info-simple-accessor-type arg-info)
1670 nil)))
1671 (when (arg-info-valid-p arg-info)
1672 (dolist (method (if new-method (list new-method) methods))
1673 (let* ((specializers (if (or (eq *boot-state* 'complete)
1674 (not (consp method)))
1675 (method-specializers method)
1676 (early-method-specializers method t)))
1677 (class (if (or (eq *boot-state* 'complete) (not (consp method)))
1678 (class-of method)
1679 (early-method-class method)))
1680 (new-type (when (and class
1681 (or (not (eq *boot-state* 'complete))
1682 (eq (generic-function-method-combination gf)
1683 *standard-method-combination*)))
1684 (cond ((eq class *the-class-standard-reader-method*)
1685 'reader)
1686 ((eq class *the-class-standard-writer-method*)
1687 'writer)
1688 ((eq class *the-class-standard-boundp-method*)
1689 'boundp)))))
1690 (setq metatypes (mapcar #'raise-metatype metatypes specializers))
1691 (setq type (cond ((null type) new-type)
1692 ((eq type new-type) type)
1693 (t nil)))))
1694 (setf (arg-info-metatypes arg-info) metatypes)
1695 (setf (gf-info-simple-accessor-type arg-info) type)))
1696 (when (or (not was-valid-p) first-p)
1697 (multiple-value-bind (c-a-m-emf std-p)
1698 (if (early-gf-p gf)
1699 (values t t)
1700 (compute-applicable-methods-emf gf))
1701 (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
1702 (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
1703 (unless (gf-info-c-a-m-emf-std-p arg-info)
1704 (setf (gf-info-simple-accessor-type arg-info) t))))
1705 ;;
1706 ;; Let dfuns and emfs be pre-computed for "normal" PCL methods, not
1707 ;; the ones generated in the course of optimizations.
1708 (unless was-valid-p
1709 (let ((name (if (eq *boot-state* 'complete)
1710 (generic-function-name gf)
1711 (early-gf-name gf))))
1712 (setf (gf-precompute-dfun-and-emf-p arg-info)
1713 (multiple-value-bind (valid sym)
1714 (valid-function-name-p name)
1715 (and valid
1716 (not (pcl-internal-function-name-p name))
1717 (symbolp sym)
1718 (let ((pkg (symbol-package sym))
1719 (pcl *the-pcl-package*))
1720 (or (eq pkg pcl)
1721 (memq pkg (package-use-list pcl)))))))))
1722 ;;
1723 (setf (gf-info-fast-mf-p arg-info)
1724 (or (not (eq *boot-state* 'complete))
1725 (let* ((method-class (generic-function-method-class gf))
1726 (methods (compute-applicable-methods
1727 #'make-method-lambda
1728 (list gf (class-prototype method-class)
1729 '(lambda) nil))))
1730 (and methods (null (cdr methods))
1731 (let ((specls (method-specializers (car methods))))
1732 (and (classp (car specls))
1733 (eq 'standard-generic-function
1734 (class-name (car specls)))
1735 (classp (cadr specls))
1736 (eq 'standard-method
1737 (class-name (cadr specls)))))))))
1738 arg-info)
1739
1740 ;;;
1741 ;;; This is the early definition of ensure-generic-function-using-class.
1742 ;;;
1743 ;;; The static-slots field of the funcallable instances used as early generic
1744 ;;; functions is used to store the early methods and early discriminator code
1745 ;;; for the early generic function. The static slots field of the fins
1746 ;;; contains a list whose:
1747 ;;; CAR - a list of the early methods on this early gf
1748 ;;; CADR - the early discriminator code for this method
1749 ;;;
1750 #-loadable-pcl
1751 (defun ensure-generic-function-using-class
1752 (existing spec &rest keys
1753 &key (lambda-list nil lambda-list-p) argument-precedence-order
1754 definition-source
1755 &allow-other-keys)
1756 (declare (ignore keys))
1757 (cond ((and existing (early-gf-p existing))
1758 existing)
1759 ((assoc spec *generic-function-fixups* :test #'equal)
1760 (if existing
1761 (make-early-gf spec lambda-list lambda-list-p existing
1762 argument-precedence-order)
1763 (error _"~@<The function ~S is not already defined.~@:>" spec)))
1764 (existing
1765 (error _"~@<~S should be on the list ~S.~@:>" spec
1766 '*generic-function-fixups*))
1767 (t
1768 (pushnew spec *early-generic-functions* :test #'equal)
1769 (make-early-gf spec lambda-list lambda-list-p nil
1770 argument-precedence-order definition-source))))
1771
1772 (defun make-early-gf (spec &optional lambda-list lambda-list-p function
1773 argument-precedence-order source)
1774 (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
1775 (set-funcallable-instance-function
1776 fin
1777 (or function
1778 (if (eq spec 'print-object)
1779 #'(kernel:instance-lambda (instance stream)
1780 (print-unreadable-object (instance stream :identity t)
1781 (format stream "std-instance")))
1782 #'(kernel:instance-lambda (&rest args)
1783 (declare (ignore args))
1784 (error _"~@<The function of the funcallable instance ~S ~
1785 has not been set.~@:>" fin)))))
1786 (setf (gdefinition spec) fin)
1787 (bootstrap-set-slot 'standard-generic-function fin 'name spec)
1788 (bootstrap-set-slot 'standard-generic-function fin 'source source)
1789 (set-function-name fin spec)
1790 (let ((arg-info (make-arg-info)))
1791 (setf (early-gf-arg-info fin) arg-info)
1792 (when lambda-list-p
1793 (if argument-precedence-order
1794 (set-arg-info fin
1795 :lambda-list lambda-list
1796 :argument-precedence-order
1797 argument-precedence-order)
1798 (set-arg-info fin :lambda-list lambda-list))))
1799 fin))
1800
1801 ;;;
1802 ;;; When loading PCL on top of itself, generic dispatch functions and
1803 ;;; effective methods would normally be recomputed when methods are
1804 ;;; defined. This is a problem because many generic functions are
1805 ;;; called in the implementation of dispatch and effective method
1806 ;;; functions (the meta-circularity). These generic functions cannot
1807 ;;; be called until their dispatch functions and effective methods are
1808 ;;; computed.
1809 ;;;
1810 ;;; We prevent here the setting of GF-DFUN-STATE to NIL. This has the
1811 ;;; effect that COMPUTE-DISCRIMINATING-FUNCTION uses the existing
1812 ;;; discriminating function of the PCL on top of which the new PCL is
1813 ;;; loaded. The generic functions affected are collected in
1814 ;;; *GENERIC-FUNCTIONS-TO-RECOMPUTE* for later fixing.
1815 ;;;
1816
1817 (defvar *loading-pcl-p* nil)
1818
1819 (defvar *generic-functions-to-recompute* ())
1820
1821 (defun set-dfun (gf &optional dfun cache info)
1822 (when cache
1823 (setf (cache-owner cache) gf))
1824 (let ((new-state (if (and dfun (or cache info))
1825 (list* dfun cache info)
1826 dfun)))
1827 (if (eq *boot-state* 'complete)
1828 #+loadable-pcl
1829 (if (and *loading-pcl-p* (null new-state))
1830 (pushnew gf *generic-functions-to-recompute*)
1831 (setf (gf-dfun-state gf) new-state))
1832 #-loadable-pcl
1833 (setf (gf-dfun-state gf) new-state)
1834 (setf (slot-ref (get-slots gf) *sgf-dfun-state-index*) new-state)))
1835 dfun)
1836
1837 (defun recompute-generic-functions ()
1838 (let ((*loading-pcl-p* nil))
1839 (mapc #'update-dfun *generic-functions-to-recompute*)))
1840
1841 (defun gf-dfun-cache (gf)
1842 (let ((state (if (eq *boot-state* 'complete)
1843 (gf-dfun-state gf)
1844 (slot-ref (get-slots gf) *sgf-dfun-state-index*))))
1845 (typecase state
1846 (function nil)
1847 (cons (cadr state)))))
1848
1849 (defun gf-dfun-info (gf)
1850 (let ((state (if (eq *boot-state* 'complete)
1851 (gf-dfun-state gf)
1852 (slot-ref (get-slots gf) *sgf-dfun-state-index*))))
1853 (typecase state
1854 (function nil)
1855 (cons (cddr state)))))
1856
1857 (defvar *sgf-name-index*
1858 (bootstrap-slot-index 'standard-generic-function 'name))
1859
1860 (defun early-gf-name (gf)
1861 (slot-ref (get-slots gf) *sgf-name-index*))
1862
1863 (defun gf-lambda-list-from-method (method)
1864 (multiple-value-bind (parameters unspecialized-lambda-list)
1865 (parse-specialized-lambda-list (method-lambda-list* method))
1866 (declare (ignore parameters))
1867 (let ((aux (memq '&aux unspecialized-lambda-list)))
1868 (ldiff unspecialized-lambda-list aux))))
1869
1870 (defun gf-lambda-list (gf)
1871 (let ((arg-info (if (eq *boot-state* 'complete)
1872 (gf-arg-info gf)
1873 (early-gf-arg-info gf))))
1874 (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
1875 (let ((methods (if (eq *boot-state* 'complete)
1876 (generic-function-methods gf)
1877 (early-gf-methods gf))))
1878 (if (null methods)
1879 (internal-error _"~@<No way to determine the lambda list~@:>")
1880 (gf-lambda-list-from-method (car (last methods)))))
1881 (arg-info-lambda-list arg-info))))
1882
1883 (defmacro real-ensure-gf-internal (gf-class all-keys env)
1884 `(progn
1885 (cond ((symbolp ,gf-class)
1886 (setq ,gf-class (find-class ,gf-class t ,env)))
1887 ((classp ,gf-class))
1888 (t
1889 (error _"~@<The ~s argument (~S) was neither a class nor a ~
1890 symbol naming a class.~@:>"
1891 :generic-function-class ,gf-class)))
1892 (remf ,all-keys :generic-function-class)
1893 (remf ,all-keys :environment)
1894 (remf ,all-keys :declare)
1895 (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
1896 (unless (eq combin '.shes-not-there.)
1897 (setf (getf ,all-keys :method-combination)
1898 (find-method-combination (class-prototype ,gf-class)
1899 (car combin)
1900 (cdr combin)))))
1901 (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
1902 (unless (eq method-class '.shes-not-there.)
1903 (setf (getf ,all-keys :method-class)
1904 (if (symbolp method-class)
1905 (find-class method-class t ,env)
1906 method-class))))))
1907
1908 #+loadable-pcl
1909 (progn
1910 (defmethod ensure-generic-function-using-class
1911 ((existing generic-function)
1912 function-specifier
1913 &rest all-keys
1914 &key environment
1915 (lambda-list nil lambda-list-p)
1916 (generic-function-class 'standard-generic-function gf-class-p)
1917 &allow-other-keys)
1918 (real-ensure-gf-internal generic-function-class all-keys environment)
1919 (unless (or (null gf-class-p)
1920 (eq (class-of existing) generic-function-class))
1921 (change-class existing generic-function-class))
1922 (prog1
1923 (apply #'reinitialize-instance existing all-keys)
1924 (when lambda-list-p
1925 (proclaim-defgeneric function-specifier lambda-list))))
1926
1927 (defmethod ensure-generic-function-using-class
1928 ((existing null)
1929 function-specifier
1930 &rest all-keys
1931 &key environment (lambda-list nil lambda-list-p)
1932 (generic-function-class 'standard-generic-function)
1933 &allow-other-keys)
1934 (declare (ignore existing))
1935 (real-ensure-gf-internal generic-function-class all-keys environment)
1936 (prog1
1937 (setf (gdefinition function-specifier)
1938 (apply #'make-instance generic-function-class
1939 :name function-specifier all-keys))
1940 (when lambda-list-p
1941 (proclaim-defgeneric function-specifier lambda-list)))))
1942
1943 ;;;
1944 ;;; These two are like the methods above, but used during bootstrapping.
1945 ;;; During the bootstrapping procedure they are added as methods
1946 ;;; to ENSURE-GENERIC-FUNCTION-USING-CLASS.
1947 ;;;
1948
1949 #-loadable-pcl
1950 (progn
1951 (defun real-ensure-gf-using-class--generic-function
1952 (existing
1953 function-specifier
1954 &rest all-keys
1955 &key environment (lambda-list nil lambda-list-p)
1956 (generic-function-class 'standard-generic-function gf-class-p)
1957 &allow-other-keys)
1958 (real-ensure-gf-internal generic-function-class all-keys environment)
1959 (unless (or (null gf-class-p)
1960 (eq (class-of existing) generic-function-class))
1961 (change-class existing generic-function-class))
1962 (prog1
1963 (apply #'reinitialize-instance existing all-keys)
1964 (when lambda-list-p
1965 (proclaim-defgeneric function-specifier lambda-list))))
1966
1967 (defun real-ensure-gf-using-class--null
1968 (existing
1969 function-specifier
1970 &rest all-keys
1971 &key environment (lambda-list nil lambda-list-p)
1972 (generic-function-class 'standard-generic-function)
1973 &allow-other-keys)
1974 (declare (ignore existing))
1975 (real-ensure-gf-internal generic-function-class all-keys environment)
1976 (prog1
1977 (setf (gdefinition function-specifier)
1978 (apply #'make-instance generic-function-class
1979 :name function-specifier all-keys))
1980 (when lambda-list-p
1981 (proclaim-defgeneric function-specifier lambda-list)))))
1982
1983
1984
1985 (defun get-generic-function-info (gf)
1986 ;; values nreq applyp metatypes nkeys arg-info
1987 (multiple-value-bind (applyp metatypes arg-info)
1988 (let* ((arg-info (gf-arg-info* gf))
1989 (metatypes (arg-info-metatypes arg-info)))
1990 (values (arg-info-applyp arg-info)
1991 metatypes
1992 arg-info))
1993 (values (length metatypes) applyp metatypes
1994 (count-if (lambda (x) (neq x t)) metatypes)
1995 arg-info)))
1996
1997 #-loadable-pcl
1998 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
1999 &optional slot-name)
2000 (initialize-method-function initargs)
2001 (let ((parsed ())
2002 (unparsed ()))
2003 ;; Figure out whether we got class objects or class names as the
2004 ;; specializers and set parsed and unparsed appropriately. If we
2005 ;; got class objects, then we can compute unparsed, but if we got
2006 ;; class names we don't try to compute parsed.
2007 ;;
2008 ;; Note that the use of not symbolp in this call to every should be
2009 ;; read as 'classp' we can't use classp itself because it doesn't
2010 ;; exist yet.
2011 (if (every (lambda (s) (not (symbolp s))) specializers)
2012 (setq parsed specializers
2013 unparsed (mapcar (lambda (s)
2014 (if (eq s t) t (class-name s)))
2015 specializers))
2016 (setq unparsed specializers
2017 parsed ()))
2018 (list :early-method ;This is an early method dammit!
2019
2020 (getf initargs :function)
2021 (getf initargs :fast-function)
2022
2023 parsed ;The parsed specializers. This is used
2024 ;by early-method-specializers to cache
2025 ;the parse. Note that this only comes
2026 ;into play when there is more than one
2027 ;early method on an early gf.
2028
2029 (list class ;A list to which real-make-a-method
2030 qualifiers ;can be applied to make a real method
2031 arglist ;corresponding to this early one.
2032 unparsed
2033 initargs
2034 doc
2035 slot-name)
2036 )))
2037
2038 (defun #+loadable-pcl make-a-method #-loadable-pcl real-make-a-method
2039 (class qualifiers lambda-list specializers initargs doc
2040 &optional slot-name)
2041 (setq specializers (parse-specializers specializers))
2042 (apply #'make-instance class
2043 :qualifiers qualifiers
2044 :lambda-list lambda-list
2045 :specializers specializers
2046 :documentation doc
2047 :slot-name slot-name
2048 :allow-other-keys t
2049 initargs))
2050
2051 (defun early-method-function (early-method)
2052 (values (cadr early-method) (caddr early-method)))
2053
2054 (defun early-method-class (early-method)
2055 (find-class (car (fifth early-method))))
2056
2057 (defun early-method-standard-accessor-p (early-method)
2058 (let ((class (first (fifth early-method))))
2059 (or (eq class 'standard-reader-method)
2060 (eq class 'standard-writer-method)
2061 (eq class 'standard-boundp-method))))
2062
2063 (defun early-method-standard-accessor-slot-name (early-method)
2064 (seventh (fifth early-method)))
2065
2066 ;;;
2067 ;;; Fetch the specializers of an early method. This is basically just a
2068 ;;; simple accessor except that when the second argument is t, this converts
2069 ;;; the specializers from symbols into class objects. The class objects
2070 ;;; are cached in the early method, this makes bootstrapping faster because
2071 ;;; the class objects only have to be computed once.
2072 ;;; NOTE:
2073 ;;; the second argument should only be passed as T by early-lookup-method.
2074 ;;; this is to implement the rule that only when there is more than one
2075 ;;; early method on a generic function is the conversion from class names
2076 ;;; to class objects done.
2077 ;;; the corresponds to the fact that we are only allowed to have one method
2078 ;;; on any generic function up until the time classes exist.
2079 ;;;
2080 (defun early-method-specializers (early-method &optional objectsp)
2081 (if (and (listp early-method)
2082 (eq (car early-method) :early-method))
2083 (cond ((eq objectsp t)
2084 (or (fourth early-method)
2085 (setf (fourth early-method)
2086 (mapcar #'find-class (cadddr (fifth early-method))))))
2087 (t
2088 (cadddr (fifth early-method))))
2089 (error _"~S is not an early-method." early-method)))
2090
2091 (defun early-method-qualifiers (early-method)
2092 (cadr (fifth early-method)))
2093
2094 (defun early-method-lambda-list (early-method)
2095 (caddr (fifth early-method)))
2096
2097 (defun early-add-named-method (generic-function-name
2098 qualifiers
2099 specializers
2100 arglist
2101 &rest initargs)
2102 (let* ((gf (ensure-generic-function generic-function-name))
2103 (existing
2104 (dolist (m (early-gf-methods gf))
2105 (when (and (equal (early-method-specializers m) specializers)
2106 (equal (early-method-qualifiers m) qualifiers))
2107 (return m))))
2108 (new (make-a-method 'standard-method
2109 qualifiers
2110 arglist
2111 specializers
2112 initargs
2113 ())))
2114 (when existing (remove-method gf existing))
2115 (add-method gf new)
2116 new))
2117
2118 ;;;
2119 ;;; This is the early version of add-method. Later this will become a
2120 ;;; generic function. See fix-early-generic-functions which has special
2121 ;;; knowledge about add-method.
2122 ;;;
2123 #-loadable-pcl
2124 (progn
2125 (defun add-method (generic-function method)
2126 (when (not (fsc-instance-p generic-function))
2127 (error _"Early add-method didn't get a funcallable instance."))
2128 (when (not (and (listp method) (eq (car method) :early-method)))
2129 (error _"Early add-method didn't get an early method."))
2130 (push method (early-gf-methods generic-function))
2131 (set-arg-info generic-function :new-method method)
2132 (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
2133 :test #'equal)
2134 (update-dfun generic-function))
2135 generic-function)
2136
2137 ;;
2138 ;; This is the early version of remove method.
2139 ;;
2140 (defun remove-method (generic-function method)
2141 (when (not (fsc-instance-p generic-function))
2142 (error _"Early remove-method didn't get a funcallable instance."))
2143 (when (not (and (listp method) (eq (car method) :early-method)))
2144 (error _"Early remove-method didn't get an early method."))
2145 (setf (early-gf-methods generic-function)
2146 (remove method (early-gf-methods generic-function)))
2147 (set-arg-info generic-function)
2148 (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
2149 :test #'equal)
2150 (update-dfun generic-function))
2151 generic-function)
2152
2153 ;;
2154 ;; And the early version of get-method.
2155 ;;
2156 (defun get-method (generic-function qualifiers specializers
2157 &optional (errorp t))
2158 (if (early-gf-p generic-function)
2159 (or (dolist (m (early-gf-methods generic-function))
2160 (when (and (or (equal (early-method-specializers m nil)
2161 specializers)
2162 (equal (early-method-specializers m t)
2163 specializers))
2164 (equal (early-method-qualifiers m) qualifiers))
2165 (return m)))
2166 (if errorp
2167 (error _"Can't get early method.")
2168 nil))
2169 (real-get-method generic-function qualifiers specializers errorp))))
2170
2171 (defvar *fegf-debug-p* nil)
2172
2173 (defun fix-early-generic-functions (&optional (noisyp t *fegf-debug-p*))
2174 (declare (ignore noisyp))
2175 (let ((accessors nil))
2176 ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions.
2177 (dolist (early-gf-spec *early-generic-functions*)
2178 (when (every #'early-method-standard-accessor-p
2179 (early-gf-methods (gdefinition early-gf-spec)))
2180 (push early-gf-spec accessors)))
2181 (dolist (spec (nconc accessors
2182 '(accessor-method-slot-name
2183 generic-function-methods
2184 method-specializers
2185 specializerp
2186 specializer-type
2187 specializer-class
2188 slot-definition-location
2189 slot-definition-name
2190 class-slots
2191 gf-arg-info
2192 class-precedence-list
2193 slot-boundp-using-class
2194 (setf slot-value-using-class)
2195 slot-value-using-class
2196 structure-class-p
2197 standard-class-p
2198 funcallable-standard-class-p
2199 specializerp)))
2200 (setq *early-generic-functions*
2201 (cons spec (delete spec *early-generic-functions* :test #'equal))))
2202
2203 (dolist (early-gf-spec *early-generic-functions*)
2204 (let* ((gf (gdefinition early-gf-spec))
2205 (methods (mapcar (lambda (early-method)
2206 (let ((args (copy-list (fifth early-method))))
2207 (setf (fourth args)
2208 (early-method-specializers early-method t))
2209 (apply #'real-make-a-method args)))
2210 (early-gf-methods gf))))
2211 (setf (generic-function-method-class gf) *the-class-standard-method*)
2212 (setf (generic-function-method-combination gf) *standard-method-combination*)
2213 (set-methods gf methods)))
2214
2215 (dolist (fns *early-functions*)
2216 (setf (gdefinition (car fns)) (symbol-function (caddr fns))))
2217
2218 (dolist (fixup *generic-function-fixups*)
2219 (let* ((fspec (car fixup))
2220 (gf (gdefinition fspec))
2221 (methods (mapcar (lambda (method)
2222 (let* ((lambda-list (first method))
2223 (specializers (second method))
2224 (method-fn-name (third method))
2225 (fn-name (or method-fn-name fspec))
2226 (fn (symbol-function fn-name))
2227 (initargs
2228 (list :function
2229 (set-function-name
2230 (lambda (args next-methods)
2231 (declare (ignore next-methods))
2232 (apply fn args))
2233 `(call ,fn-name)))))
2234 (declare (type function fn))
2235 (make-a-method 'standard-method
2236 ()
2237 lambda-list
2238 specializers
2239 initargs
2240 nil)))
2241 (cdr fixup))))
2242 (setf (generic-function-method-class gf) *the-class-standard-method*)
2243 (setf (generic-function-method-combination gf) *standard-method-combination*)
2244 (set-methods gf methods)))))
2245
2246
2247 ;;;
2248 ;;; parse-defmethod is used by defmethod to parse the &rest argument into
2249 ;;; the 'real' arguments. This is where the syntax of defmethod is really
2250 ;;; implemented.
2251 ;;;
2252 (defun parse-defmethod (form)
2253 (declare (list form))
2254 (loop with original-form = form and name = (pop form)
2255 while (and (car form) (atom (car form)))
2256 collect (pop form) into qualifiers
2257 finally
2258 (let ((lambda-list (pop form)))
2259 (when (and (null lambda-list)
2260 (consp (car form))
2261 (consp (caar form)))
2262 (error _"~@<Qualifiers must be non-null atoms: ~s~@:>"
2263 original-form))
2264 (return (values name qualifiers lambda-list form)))))
2265
2266 (defun parse-specializers (specializers)
2267 (declare (list specializers))
2268 (flet ((parse (spec)
2269 (let ((result (specializer-from-type spec)))
2270 (if (specializerp result)
2271 result
2272 (if (symbolp spec)
2273 (error _"~@<~S used as a specializer, ~
2274 but is not the name of a class.~@:>"
2275 spec)
2276 (error _"~S is not a legal specializer." spec))))))
2277 (mapcar #'parse specializers)))
2278
2279 (defun unparse-specializers (specializers-or-method)
2280 (if (listp specializers-or-method)
2281 (flet ((unparse (spec)
2282 (if (specializerp spec)
2283 (let ((type (specializer-type spec)))
2284 (if (and (consp type)
2285 (eq (car type) 'class))
2286 (let* ((class (cadr type))
2287 (class-name (class-name class)))
2288 (if (eq class (find-class class-name nil))
2289 class-name
2290 type))
2291 type))
2292 (error _"~S is not a legal specializer." spec))))
2293 (mapcar #'unparse specializers-or-method))
2294 (unparse-specializers (method-specializers specializers-or-method))))
2295
2296 (defun parse-method-or-spec (spec &optional (errorp t))
2297 (let (gf method name temp)
2298 (if (method-p spec)
2299 (setq method spec
2300 gf (method-generic-function method)
2301 temp (and gf (generic-function-name gf))
2302 name (if temp
2303 (make-method-spec temp (method-qualifiers method)
2304 (unparse-specializers
2305 (method-specializers method)))
2306 (make-symbol (format nil "~S" method))))
2307 (multiple-value-bind (gf-spec quals specls)
2308 (parse-defmethod spec)
2309 (and (setq gf (and (or errorp (fboundp gf-spec))
2310 (gdefinition gf-spec)))
2311 (let ((nreq (arg-info-number-required
2312 (if (eq *boot-state* 'complete)
2313 (gf-arg-info gf)
2314 (early-gf-arg-info gf)))))
2315 (setq specls (append (parse-specializers specls)
2316 (make-list (- nreq (length specls))
2317 :initial-element
2318 *the-class-t*)))
2319 (and
2320 (setq method (get-method gf quals specls errorp))
2321 (setq name (make-method-spec gf-spec quals
2322 (unparse-specializers specls))))))))
2323 (values gf method name)))
2324
2325
2326 ;;;
2327 ;;; The next two functions are part of AMOP.
2328 ;;;
2329 (defun extract-lambda-list (specialized-lambda-list)
2330 (multiple-value-bind (ignore1 lambda-list ignore2)
2331 (parse-specialized-lambda-list specialized-lambda-list)
2332 (declare (ignore ignore1 ignore2))
2333 lambda-list))
2334
2335 (defun extract-specializer-names (specialized-lambda-list)
2336 (multiple-value-bind (ignore1 ignore2 specializers)
2337 (parse-specialized-lambda-list specialized-lambda-list)
2338 (declare (ignore ignore1 ignore2))
2339 specializers))
2340
2341 (defun parse-specialized-lambda-list (lambda-list)
2342 (multiple-value-bind (required optional restp rest keyp keys
2343 allow-other-keys-p aux)
2344 (parse-lambda-list lambda-list t)
2345 (collect ((req) (spec))
2346 (dolist (x required)
2347 (req (if (consp x) (car x) x))
2348 (spec (if (consp x) (cadr x) t)))
2349 (values (mapcar (lambda (x) (if (consp x) (car x) x))
2350 (append required optional (and restp (list rest))
2351 keys aux))
2352 `(,@(req)
2353 ,@(when optional `(&optional ,@optional))
2354 ,@(when restp `(&rest ,rest))
2355 ,@(when keyp `(&key ,@keys))
2356 ,@(when allow-other-keys-p `(&allow-other-keys))
2357 ,@(when aux `(&aux ,@aux)))
2358 (spec)
2359 (req)))))
2360
2361
2362 #-loadable-pcl
2363 (eval-when (:load-toplevel :execute)
2364 (/show "PCL boot state EARLY")
2365 (setq *boot-state* 'early))
2366
2367 (defmacro with-slots (slots instance &body body)
2368 (let ((in (gensym)))
2369 `(let ((,in ,instance))
2370 (declare (ignorable ,in))
2371 ,@(let ((instance (if (and (consp instance)
2372 (eq (car instance) 'the))
2373 (third instance)
2374 instance)))
2375 (and (symbolp instance)
2376 `((declare (variable-rebinding ,in ,instance)))))
2377 (symbol-macrolet ,(mapcar (lambda (slot-entry)
2378 (let ((variable-name
2379 (if (symbolp slot-entry)
2380 slot-entry
2381 (car slot-entry)))
2382 (slot-name
2383 (if (symbolp slot-entry)
2384 slot-entry
2385 (cadr slot-entry))))
2386 `(,variable-name
2387 (slot-value ,in ',slot-name))))
2388 slots)
2389 ,@body))))
2390
2391 (defmacro with-accessors (slots instance &body body)
2392 (let ((in (gensym)))
2393 `(let ((,in ,instance))
2394 (declare (ignorable ,in))
2395 ,@(let ((instance (if (and (consp instance)
2396 (eq (car instance) 'the))
2397 (third instance)
2398 instance)))
2399 (and (symbolp instance)
2400 `((declare (variable-rebinding ,in ,instance)))))
2401 (symbol-macrolet ,(mapcar (lambda (slot-entry)
2402 (let ((variable-name (car slot-entry))
2403 (accessor-name (cadr slot-entry)))
2404 `(,variable-name
2405 (,accessor-name ,in))))
2406 slots)
2407 ,@body))))

  ViewVC Help
Powered by ViewVC 1.1.5