1.0.10.49: deadline refinements
[sbcl.git] / src / pcl / boot.lisp
blobbfa56ce84da4b3b2744fbdadccbef5589ca0b115
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
24 (in-package "SB-PCL")
28 The CommonLoops evaluator is meta-circular.
30 Most of the code in PCL is methods on generic functions, including
31 most of the code that actually implements generic functions and method
32 lookup.
34 So, we have a classic bootstrapping problem. The solution to this is
35 to first get a cheap implementation of generic functions running,
36 these are called early generic functions. These early generic
37 functions and the corresponding early methods and early method lookup
38 are used to get enough of the system running that it is possible to
39 create real generic functions and methods and implement real method
40 lookup. At that point (done in the file FIXUP) the function
41 !FIX-EARLY-GENERIC-FUNCTIONS is called to convert all the early generic
42 functions to real generic functions.
44 The cheap generic functions are built using the same
45 FUNCALLABLE-INSTANCE objects that real generic functions are made out of.
46 This means that as PCL is being bootstrapped, the cheap generic
47 function objects which are being created are the same objects which
48 will later be real generic functions. This is good because:
49 - we don't cons garbage structure, and
50 - we can keep pointers to the cheap generic function objects
51 during booting because those pointers will still point to
52 the right object after the generic functions are all fixed up.
54 This file defines the DEFMETHOD macro and the mechanism used to expand
55 it. This includes the mechanism for processing the body of a method.
56 DEFMETHOD basically expands into a call to LOAD-DEFMETHOD, which
57 basically calls ADD-METHOD to add the method to the generic function.
58 These expansions can be loaded either during bootstrapping or when PCL
59 is fully up and running.
61 An important effect of this arrangement is it means we can compile
62 files with DEFMETHOD forms in them in a completely running PCL, but
63 then load those files back in during bootstrapping. This makes
64 development easier. It also means there is only one set of code for
65 processing DEFMETHOD. Bootstrapping works by being sure to have
66 LOAD-METHOD be careful to call only primitives which work during
67 bootstrapping.
71 (declaim (notinline make-a-method add-named-method
72 ensure-generic-function-using-class
73 add-method remove-method))
75 (defvar *!early-functions*
76 '((make-a-method early-make-a-method real-make-a-method)
77 (add-named-method early-add-named-method real-add-named-method)))
79 ;;; For each of the early functions, arrange to have it point to its
80 ;;; early definition. Do this in a way that makes sure that if we
81 ;;; redefine one of the early definitions the redefinition will take
82 ;;; effect. This makes development easier.
83 (dolist (fns *!early-functions*)
84 (let ((name (car fns))
85 (early-name (cadr fns)))
86 (setf (gdefinition name)
87 (set-fun-name
88 (lambda (&rest args)
89 (apply (fdefinition early-name) args))
90 name))))
92 ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
93 ;;; to convert the few functions in the bootstrap which are supposed
94 ;;; to be generic functions but can't be early on.
95 ;;;
96 ;;; each entry is a list of name and lambda-list, class names as
97 ;;; specializers, and method body function name.
98 (defvar *!generic-function-fixups*
99 '((add-method
100 ((generic-function method)
101 (standard-generic-function method)
102 real-add-method))
103 (remove-method
104 ((generic-function method)
105 (standard-generic-function method)
106 real-remove-method))
107 (get-method
108 ((generic-function qualifiers specializers &optional (errorp t))
109 (standard-generic-function t t)
110 real-get-method))
111 (ensure-generic-function-using-class
112 ((generic-function fun-name
113 &key generic-function-class environment
114 &allow-other-keys)
115 (generic-function t)
116 real-ensure-gf-using-class--generic-function)
117 ((generic-function fun-name
118 &key generic-function-class environment
119 &allow-other-keys)
120 (null t)
121 real-ensure-gf-using-class--null))
122 (make-method-lambda
123 ((proto-generic-function proto-method lambda-expression environment)
124 (standard-generic-function standard-method t t)
125 real-make-method-lambda))
126 (make-method-specializers-form
127 ((proto-generic-function proto-method specializer-names environment)
128 (standard-generic-function standard-method t t)
129 real-make-method-specializers-form))
130 (parse-specializer-using-class
131 ((generic-function specializer)
132 (standard-generic-function t)
133 real-parse-specializer-using-class))
134 (unparse-specializer-using-class
135 ((generic-function specializer)
136 (standard-generic-function t)
137 real-unparse-specializer-using-class))
138 (make-method-initargs-form
139 ((proto-generic-function proto-method
140 lambda-expression
141 lambda-list environment)
142 (standard-generic-function standard-method t t t)
143 real-make-method-initargs-form))
144 (compute-effective-method
145 ((generic-function combin applicable-methods)
146 (generic-function standard-method-combination t)
147 standard-compute-effective-method))))
149 (defmacro defgeneric (fun-name lambda-list &body options)
150 (declare (type list lambda-list))
151 (unless (legal-fun-name-p fun-name)
152 (error 'simple-program-error
153 :format-control "illegal generic function name ~S"
154 :format-arguments (list fun-name)))
155 (check-gf-lambda-list lambda-list)
156 (let ((initargs ())
157 (methods ()))
158 (flet ((duplicate-option (name)
159 (error 'simple-program-error
160 :format-control "The option ~S appears more than once."
161 :format-arguments (list name)))
162 (expand-method-definition (qab) ; QAB = qualifiers, arglist, body
163 (let* ((arglist-pos (position-if #'listp qab))
164 (arglist (elt qab arglist-pos))
165 (qualifiers (subseq qab 0 arglist-pos))
166 (body (nthcdr (1+ arglist-pos) qab)))
167 `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body)
168 (generic-function-initial-methods (fdefinition ',fun-name))))))
169 (macrolet ((initarg (key) `(getf initargs ,key)))
170 (dolist (option options)
171 (let ((car-option (car option)))
172 (case car-option
173 (declare
174 (when (and
175 (consp (cadr option))
176 (member (first (cadr option))
177 ;; FIXME: this list is slightly weird.
178 ;; ANSI (on the DEFGENERIC page) in one
179 ;; place allows only OPTIMIZE; in
180 ;; another place gives this list of
181 ;; disallowed declaration specifiers.
182 ;; This seems to be the only place where
183 ;; the FUNCTION declaration is
184 ;; mentioned; TYPE seems to be missing.
185 ;; Very strange. -- CSR, 2002-10-21
186 '(declaration ftype function
187 inline notinline special)))
188 (error 'simple-program-error
189 :format-control "The declaration specifier ~S ~
190 is not allowed inside DEFGENERIC."
191 :format-arguments (list (cadr option))))
192 (push (cadr option) (initarg :declarations)))
193 (:method-combination
194 (when (initarg car-option)
195 (duplicate-option car-option))
196 (unless (symbolp (cadr option))
197 (error 'simple-program-error
198 :format-control "METHOD-COMBINATION name not a ~
199 symbol: ~S"
200 :format-arguments (list (cadr option))))
201 (setf (initarg car-option)
202 `',(cdr option)))
203 (:argument-precedence-order
204 (let* ((required (parse-lambda-list lambda-list))
205 (supplied (cdr option)))
206 (unless (= (length required) (length supplied))
207 (error 'simple-program-error
208 :format-control "argument count discrepancy in ~
209 :ARGUMENT-PRECEDENCE-ORDER clause."
210 :format-arguments nil))
211 (when (set-difference required supplied)
212 (error 'simple-program-error
213 :format-control "unequal sets for ~
214 :ARGUMENT-PRECEDENCE-ORDER clause: ~
215 ~S and ~S"
216 :format-arguments (list required supplied)))
217 (setf (initarg car-option)
218 `',(cdr option))))
219 ((:documentation :generic-function-class :method-class)
220 (unless (proper-list-of-length-p option 2)
221 (error "bad list length for ~S" option))
222 (if (initarg car-option)
223 (duplicate-option car-option)
224 (setf (initarg car-option) `',(cadr option))))
225 (:method
226 (push (cdr option) methods))
228 ;; ANSI requires that unsupported things must get a
229 ;; PROGRAM-ERROR.
230 (error 'simple-program-error
231 :format-control "unsupported option ~S"
232 :format-arguments (list option))))))
234 (when (initarg :declarations)
235 (setf (initarg :declarations)
236 `',(initarg :declarations))))
237 `(progn
238 (eval-when (:compile-toplevel :load-toplevel :execute)
239 (compile-or-load-defgeneric ',fun-name))
240 (load-defgeneric ',fun-name ',lambda-list
241 (sb-c:source-location) ,@initargs)
242 ,@(mapcar #'expand-method-definition methods)
243 (fdefinition ',fun-name)))))
245 (defun compile-or-load-defgeneric (fun-name)
246 (proclaim-as-fun-name fun-name)
247 (note-name-defined fun-name :function)
248 (unless (eq (info :function :where-from fun-name) :declared)
249 (setf (info :function :where-from fun-name) :defined)
250 (setf (info :function :type fun-name)
251 (specifier-type 'function))))
253 (defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
254 (when (fboundp fun-name)
255 (style-warn "redefining ~S in DEFGENERIC" fun-name)
256 (let ((fun (fdefinition fun-name)))
257 (when (generic-function-p fun)
258 (loop for method in (generic-function-initial-methods fun)
259 do (remove-method fun method))
260 (setf (generic-function-initial-methods fun) '()))))
261 (apply #'ensure-generic-function
262 fun-name
263 :lambda-list lambda-list
264 :definition-source source-location
265 initargs))
267 (define-condition generic-function-lambda-list-error
268 (reference-condition simple-program-error)
270 (:default-initargs :references (list '(:ansi-cl :section (3 4 2)))))
272 (defun check-gf-lambda-list (lambda-list)
273 (flet ((ensure (arg ok)
274 (unless ok
275 (error 'generic-function-lambda-list-error
276 :format-control
277 "~@<invalid ~S ~_in the generic function lambda list ~S~:>"
278 :format-arguments (list arg lambda-list)))))
279 (multiple-value-bind (required optional restp rest keyp keys allowp
280 auxp aux morep more-context more-count)
281 (parse-lambda-list lambda-list)
282 (declare (ignore required)) ; since they're no different in a gf ll
283 (declare (ignore restp rest)) ; since they're no different in a gf ll
284 (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way
285 (declare (ignore aux)) ; since we require AUXP=NIL
286 (declare (ignore more-context more-count)) ; safely ignored unless MOREP
287 ;; no defaults allowed for &OPTIONAL arguments
288 (dolist (i optional)
289 (ensure i (or (symbolp i)
290 (and (consp i) (symbolp (car i)) (null (cdr i))))))
291 ;; no defaults allowed for &KEY arguments
292 (when keyp
293 (dolist (i keys)
294 (ensure i (or (symbolp i)
295 (and (consp i)
296 (or (symbolp (car i))
297 (and (consp (car i))
298 (symbolp (caar i))
299 (symbolp (cadar i))
300 (null (cddar i))))
301 (null (cdr i)))))))
302 ;; no &AUX allowed
303 (when auxp
304 (error "&AUX is not allowed in a generic function lambda list: ~S"
305 lambda-list))
306 ;; Oh, *puhlease*... not specifically as per section 3.4.2 of
307 ;; the ANSI spec, but the CMU CL &MORE extension does not
308 ;; belong here!
309 (aver (not morep)))))
311 (defmacro defmethod (&rest args)
312 (multiple-value-bind (name qualifiers lambda-list body)
313 (parse-defmethod args)
314 `(progn
315 ;; KLUDGE: this double expansion is quite a monumental
316 ;; workaround: it comes about because of a fantastic interaction
317 ;; between the processing rules of CLHS 3.2.3.1 and the
318 ;; bizarreness of MAKE-METHOD-LAMBDA.
320 ;; MAKE-METHOD-LAMBDA can be called by the user, and if the
321 ;; lambda itself doesn't refer to outside bindings the return
322 ;; value must be compileable in the null lexical environment.
323 ;; However, the function must also refer somehow to the
324 ;; associated method object, so that it can call NO-NEXT-METHOD
325 ;; with the appropriate arguments if there is no next method --
326 ;; but when the function is generated, the method object doesn't
327 ;; exist yet.
329 ;; In order to resolve this issue, we insert a literal cons cell
330 ;; into the body of the method lambda, return the same cons cell
331 ;; as part of the second (initargs) return value of
332 ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills
333 ;; in the cell when the method is created. However, this
334 ;; strategy depends on having a fresh cons cell for every method
335 ;; lambda, which (without the workaround below) is skewered by
336 ;; the processing in CLHS 3.2.3.1, which permits implementations
337 ;; to macroexpand the bodies of EVAL-WHEN forms with both
338 ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once. The
339 ;; expansion below forces the double expansion in those cases,
340 ;; while expanding only once in the common case.
341 (eval-when (:load-toplevel)
342 (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))
343 (eval-when (:execute)
344 (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))
346 (defmacro %defmethod-expander
347 (name qualifiers lambda-list body &environment env)
348 (multiple-value-bind (proto-gf proto-method)
349 (prototypes-for-make-method-lambda name)
350 (expand-defmethod name proto-gf proto-method qualifiers
351 lambda-list body env)))
354 (defun prototypes-for-make-method-lambda (name)
355 (if (not (eq *boot-state* 'complete))
356 (values nil nil)
357 (let ((gf? (and (fboundp name)
358 (gdefinition name))))
359 (if (or (null gf?)
360 (not (generic-function-p gf?)))
361 (values (class-prototype (find-class 'standard-generic-function))
362 (class-prototype (find-class 'standard-method)))
363 (values gf?
364 (class-prototype (or (generic-function-method-class gf?)
365 (find-class 'standard-method))))))))
367 ;;; Take a name which is either a generic function name or a list specifying
368 ;;; a SETF generic function (like: (SETF <generic-function-name>)). Return
369 ;;; the prototype instance of the method-class for that generic function.
371 ;;; If there is no generic function by that name, this returns the
372 ;;; default value, the prototype instance of the class
373 ;;; STANDARD-METHOD. This default value is also returned if the spec
374 ;;; names an ordinary function or even a macro. In effect, this leaves
375 ;;; the signalling of the appropriate error until load time.
377 ;;; Note: During bootstrapping, this function is allowed to return NIL.
378 (defun method-prototype-for-gf (name)
379 (let ((gf? (and (fboundp name)
380 (gdefinition name))))
381 (cond ((neq *boot-state* 'complete) nil)
382 ((or (null gf?)
383 (not (generic-function-p gf?))) ; Someone else MIGHT
384 ; error at load time.
385 (class-prototype (find-class 'standard-method)))
387 (class-prototype (or (generic-function-method-class gf?)
388 (find-class 'standard-method)))))))
390 (defun expand-defmethod (name
391 proto-gf
392 proto-method
393 qualifiers
394 lambda-list
395 body
396 env)
397 (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
398 (add-method-declarations name qualifiers lambda-list body env)
399 (multiple-value-bind (method-function-lambda initargs)
400 (make-method-lambda proto-gf proto-method method-lambda env)
401 (let ((initargs-form (make-method-initargs-form
402 proto-gf proto-method method-function-lambda
403 initargs env))
404 (specializers-form (make-method-specializers-form
405 proto-gf proto-method specializers env)))
406 `(progn
407 ;; Note: We could DECLAIM the ftype of the generic function
408 ;; here, since ANSI specifies that we create it if it does
409 ;; not exist. However, I chose not to, because I think it's
410 ;; more useful to support a style of programming where every
411 ;; generic function has an explicit DEFGENERIC and any typos
412 ;; in DEFMETHODs are warned about. Otherwise
414 ;; (DEFGENERIC FOO-BAR-BLETCH (X))
415 ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
416 ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
417 ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
418 ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
419 ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
421 ;; compiles without raising an error and runs without
422 ;; raising an error (since SIMPLE-VECTOR cases fall through
423 ;; to VECTOR) but still doesn't do what was intended. I hate
424 ;; that kind of bug (code which silently gives the wrong
425 ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
426 ,(make-defmethod-form name qualifiers specializers-form
427 unspecialized-lambda-list
428 (if proto-method
429 (class-name (class-of proto-method))
430 'standard-method)
431 initargs-form))))))
433 (defun interned-symbol-p (x)
434 (and (symbolp x) (symbol-package x)))
436 (defun make-defmethod-form
437 (name qualifiers specializers unspecialized-lambda-list
438 method-class-name initargs-form)
439 (let (fn
440 fn-lambda)
441 (if (and (interned-symbol-p (fun-name-block-name name))
442 (every #'interned-symbol-p qualifiers)
443 (every (lambda (s)
444 (if (consp s)
445 (and (eq (car s) 'eql)
446 (constantp (cadr s))
447 (let ((sv (constant-form-value (cadr s))))
448 (or (interned-symbol-p sv)
449 (integerp sv)
450 (and (characterp sv)
451 (standard-char-p sv)))))
452 (interned-symbol-p s)))
453 specializers)
454 (consp initargs-form)
455 (eq (car initargs-form) 'list*)
456 (memq (cadr initargs-form) '(:function))
457 (consp (setq fn (caddr initargs-form)))
458 (eq (car fn) 'function)
459 (consp (setq fn-lambda (cadr fn)))
460 (eq (car fn-lambda) 'lambda)
461 (bug "Really got here"))
462 (let* ((specls (mapcar (lambda (specl)
463 (if (consp specl)
464 ;; CONSTANT-FORM-VALUE? What I
465 ;; kind of want to know, though,
466 ;; is what happens if we don't do
467 ;; this for some slow-method
468 ;; function because of a hairy
469 ;; lexenv -- is the only bad
470 ;; effect that the method
471 ;; function ends up unnamed? If
472 ;; so, couldn't we arrange to
473 ;; name it later?
474 `(,(car specl) ,(eval (cadr specl)))
475 specl))
476 specializers))
477 (mname `(,(if (eq (cadr initargs-form) :function)
478 'slow-method 'fast-method)
479 ,name ,@qualifiers ,specls)))
480 `(progn
481 (defun ,mname ,(cadr fn-lambda)
482 ,@(cddr fn-lambda))
483 ,(make-defmethod-form-internal
484 name qualifiers `',specls
485 unspecialized-lambda-list method-class-name
486 `(list* ,(cadr initargs-form)
487 #',mname
488 ,@(cdddr initargs-form)))))
489 (make-defmethod-form-internal
490 name qualifiers
491 specializers
492 #+nil
493 `(list ,@(mapcar (lambda (specializer)
494 (if (consp specializer)
495 ``(,',(car specializer)
496 ,,(cadr specializer))
497 `',specializer))
498 specializers))
499 unspecialized-lambda-list
500 method-class-name
501 initargs-form))))
503 (defun make-defmethod-form-internal
504 (name qualifiers specializers-form unspecialized-lambda-list
505 method-class-name initargs-form)
506 `(load-defmethod
507 ',method-class-name
508 ',name
509 ',qualifiers
510 ,specializers-form
511 ',unspecialized-lambda-list
512 ,initargs-form
513 (sb-c:source-location)))
515 (defmacro make-method-function (method-lambda &environment env)
516 (multiple-value-bind (proto-gf proto-method)
517 (prototypes-for-make-method-lambda nil)
518 (multiple-value-bind (method-function-lambda initargs)
519 (make-method-lambda proto-gf proto-method method-lambda env)
520 (make-method-initargs-form proto-gf
521 proto-method
522 method-function-lambda
523 initargs
524 env))))
526 (defun add-method-declarations (name qualifiers lambda-list body env)
527 (declare (ignore env))
528 (multiple-value-bind (parameters unspecialized-lambda-list specializers)
529 (parse-specialized-lambda-list lambda-list)
530 (multiple-value-bind (real-body declarations documentation)
531 (parse-body body)
532 (values `(lambda ,unspecialized-lambda-list
533 ,@(when documentation `(,documentation))
534 ;; (Old PCL code used a somewhat different style of
535 ;; list for %METHOD-NAME values. Our names use
536 ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
537 ;; method names look more like what you see in a
538 ;; DEFMETHOD form.)
540 ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
541 ;; least the code to set up named BLOCKs around the
542 ;; bodies of methods, depends on the function's base
543 ;; name being the first element of the %METHOD-NAME
544 ;; list. It would be good to remove this dependency,
545 ;; perhaps by building the BLOCK here, or by using
546 ;; another declaration (e.g. %BLOCK-NAME), so that
547 ;; our method debug names are free to have any format,
548 ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
550 ;; Further, as of sbcl-0.7.9.10, the code to
551 ;; implement NO-NEXT-METHOD is coupled to the form of
552 ;; this declaration; see the definition of
553 ;; CALL-NO-NEXT-METHOD (and the passing of
554 ;; METHOD-NAME-DECLARATION arguments around the
555 ;; various CALL-NEXT-METHOD logic).
556 (declare (%method-name (,name
557 ,@qualifiers
558 ,specializers)))
559 (declare (%method-lambda-list ,@lambda-list))
560 ,@declarations
561 ,@real-body)
562 unspecialized-lambda-list specializers))))
564 (defun real-make-method-initargs-form (proto-gf proto-method
565 method-lambda initargs env)
566 (declare (ignore proto-gf proto-method))
567 (unless (and (consp method-lambda)
568 (eq (car method-lambda) 'lambda))
569 (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
570 is not a lambda form."
571 method-lambda))
572 (make-method-initargs-form-internal method-lambda initargs env))
574 (unless (fboundp 'make-method-initargs-form)
575 (setf (gdefinition 'make-method-initargs-form)
576 (symbol-function 'real-make-method-initargs-form)))
578 ;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular
579 ;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of
580 ;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the
581 ;;; REAL-MAKE-METHOD lambda is used as the body of the default method.
582 ;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function
583 ;;; so that changing it in a live image is easy, and changes actually
584 ;;; take effect.
585 (defun real-make-method-lambda (proto-gf proto-method method-lambda env)
586 (make-method-lambda-internal proto-gf proto-method method-lambda env))
588 (unless (fboundp 'make-method-lambda)
589 (setf (gdefinition 'make-method-lambda)
590 (symbol-function 'real-make-method-lambda)))
592 (defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
593 (declare (ignore proto-gf proto-method))
594 (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
595 (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
596 is not a lambda form."
597 method-lambda))
598 (multiple-value-bind (real-body declarations documentation)
599 (parse-body (cddr method-lambda))
600 (let* ((name-decl (get-declaration '%method-name declarations))
601 (sll-decl (get-declaration '%method-lambda-list declarations))
602 (method-name (when (consp name-decl) (car name-decl)))
603 (generic-function-name (when method-name (car method-name)))
604 (specialized-lambda-list (or sll-decl (cadr method-lambda)))
605 ;; the method-cell is a way of communicating what method a
606 ;; method-function implements, for the purpose of
607 ;; NO-NEXT-METHOD. We need something that can be shared
608 ;; between function and initargs, but not something that
609 ;; will be coalesced as a constant (because we are naughty,
610 ;; oh yes) with the expansion of any other methods in the
611 ;; same file. -- CSR, 2007-05-30
612 (method-cell (list (make-symbol "METHOD-CELL"))))
613 (multiple-value-bind (parameters lambda-list specializers)
614 (parse-specialized-lambda-list specialized-lambda-list)
615 (let* ((required-parameters
616 (mapcar (lambda (r s) (declare (ignore s)) r)
617 parameters
618 specializers))
619 (slots (mapcar #'list required-parameters))
620 (class-declarations
621 `(declare
622 ;; These declarations seem to be used by PCL to pass
623 ;; information to itself; when I tried to delete 'em
624 ;; ca. 0.6.10 it didn't work. I'm not sure how
625 ;; they work, but note the (VAR-DECLARATION '%CLASS ..)
626 ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
627 ,@(remove nil
628 (mapcar (lambda (a s) (and (symbolp s)
629 (neq s t)
630 `(%class ,a ,s)))
631 parameters
632 specializers))
633 ;; These TYPE declarations weren't in the original
634 ;; PCL code, but the Python compiler likes them a
635 ;; lot. (We're telling the compiler about our
636 ;; knowledge of specialized argument types so that
637 ;; it can avoid run-time type dispatch overhead,
638 ;; which can be a huge win for Python.)
640 ;; KLUDGE: when I tried moving these to
641 ;; ADD-METHOD-DECLARATIONS, things broke. No idea
642 ;; why. -- CSR, 2004-06-16
643 ,@(mapcar #'parameter-specializer-declaration-in-defmethod
644 parameters
645 specializers)))
646 (method-lambda
647 ;; Remove the documentation string and insert the
648 ;; appropriate class declarations. The documentation
649 ;; string is removed to make it easy for us to insert
650 ;; new declarations later, they will just go after the
651 ;; CADR of the method lambda. The class declarations
652 ;; are inserted to communicate the class of the method's
653 ;; arguments to the code walk.
654 `(lambda ,lambda-list
655 ;; The default ignorability of method parameters
656 ;; doesn't seem to be specified by ANSI. PCL had
657 ;; them basically ignorable but was a little
658 ;; inconsistent. E.g. even though the two
659 ;; method definitions
660 ;; (DEFMETHOD FOO ((X T) (Y T)) "Z")
661 ;; (DEFMETHOD FOO ((X T) Y) "Z")
662 ;; are otherwise equivalent, PCL treated Y as
663 ;; ignorable in the first definition but not in the
664 ;; second definition. We make all required
665 ;; parameters ignorable as a way of systematizing
666 ;; the old PCL behavior. -- WHN 2000-11-24
667 (declare (ignorable ,@required-parameters))
668 ,class-declarations
669 ,@declarations
670 (block ,(fun-name-block-name generic-function-name)
671 ,@real-body)))
672 (constant-value-p (and (null (cdr real-body))
673 (constantp (car real-body))))
674 (constant-value (and constant-value-p
675 (constant-form-value (car real-body))))
676 (plist (and constant-value-p
677 (or (typep constant-value
678 '(or number character))
679 (and (symbolp constant-value)
680 (symbol-package constant-value)))
681 (list :constant-value constant-value)))
682 (applyp (dolist (p lambda-list nil)
683 (cond ((memq p '(&optional &rest &key))
684 (return t))
685 ((eq p '&aux)
686 (return nil))))))
687 (multiple-value-bind
688 (walked-lambda call-next-method-p closurep
689 next-method-p-p setq-p
690 parameters-setqd)
691 (walk-method-lambda method-lambda
692 required-parameters
694 slots)
695 (multiple-value-bind (walked-lambda-body
696 walked-declarations
697 walked-documentation)
698 (parse-body (cddr walked-lambda))
699 (declare (ignore walked-documentation))
700 (when (some #'cdr slots)
701 (let ((slot-name-lists (slot-name-lists-from-slots slots)))
702 (setq plist
703 `(,@(when slot-name-lists
704 `(:slot-name-lists ,slot-name-lists))
705 ,@plist))
706 (setq walked-lambda-body
707 `((pv-binding (,required-parameters
708 ,slot-name-lists
709 (load-time-value
710 (intern-pv-table
711 :slot-name-lists ',slot-name-lists)))
712 ,@walked-lambda-body)))))
713 (when (and (memq '&key lambda-list)
714 (not (memq '&allow-other-keys lambda-list)))
715 (let ((aux (memq '&aux lambda-list)))
716 (setq lambda-list (nconc (ldiff lambda-list aux)
717 (list '&allow-other-keys)
718 aux))))
719 (values `(lambda (.method-args. .next-methods.)
720 (simple-lexical-method-functions
721 (,lambda-list .method-args. .next-methods.
722 :call-next-method-p
723 ,call-next-method-p
724 :next-method-p-p ,next-method-p-p
725 :setq-p ,setq-p
726 :method-cell ,method-cell
727 :closurep ,closurep
728 :applyp ,applyp)
729 ,@walked-declarations
730 (locally
731 (declare (disable-package-locks
732 %parameter-binding-modified))
733 (symbol-macrolet ((%parameter-binding-modified
734 ',@parameters-setqd))
735 (declare (enable-package-locks
736 %parameter-binding-modified))
737 ,@walked-lambda-body))))
738 `(,@(when call-next-method-p `(method-cell ,method-cell))
739 ,@(when plist `(plist ,plist))
740 ,@(when documentation `(:documentation ,documentation)))))))))))
742 (defun real-make-method-specializers-form
743 (proto-gf proto-method specializer-names env)
744 (declare (ignore env proto-gf proto-method))
745 (flet ((parse (name)
746 (cond
747 ((and (eq *boot-state* 'complete)
748 (specializerp name))
749 name)
750 ((symbolp name) `(find-class ',name))
751 ((consp name) (ecase (car name)
752 ((eql) `(intern-eql-specializer ,(cadr name)))
753 ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))
754 ((prototype) `(fixme))))
755 (t (bug "Foo")))))
756 `(list ,@(mapcar #'parse specializer-names))))
758 (unless (fboundp 'make-method-specializers-form)
759 (setf (gdefinition 'make-method-specializers-form)
760 (symbol-function 'real-make-method-specializers-form)))
762 (defun real-parse-specializer-using-class (generic-function specializer)
763 (let ((result (specializer-from-type specializer)))
764 (if (specializerp result)
765 result
766 (error "~@<~S cannot be parsed as a specializer for ~S.~@:>"
767 specializer generic-function))))
769 (unless (fboundp 'parse-specializer-using-class)
770 (setf (gdefinition 'parse-specializer-using-class)
771 (symbol-function 'real-parse-specializer-using-class)))
773 (defun real-unparse-specializer-using-class (generic-function specializer)
774 (if (specializerp specializer)
775 ;; FIXME: this HANDLER-CASE is a bit of a hammer to crack a nut:
776 ;; the idea is that we want to unparse permissively, so that the
777 ;; lazy (or rather the "portable") specializer extender (who
778 ;; does not define methods on these new SBCL-specific MOP
779 ;; functions) can still subclass specializer and define methods
780 ;; without everything going wrong. Making it cleaner and
781 ;; clearer that that is what we are defending against would be
782 ;; nice. -- CSR, 2007-06-01
783 (handler-case
784 (let ((type (specializer-type specializer)))
785 (if (and (consp type) (eq (car type) 'class))
786 (let* ((class (cadr type))
787 (class-name (class-name class)))
788 (if (eq class (find-class class-name nil))
789 class-name
790 type))
791 type))
792 (error () specializer))
793 (error "~@<~S is not a legal specializer for ~S.~@:>"
794 specializer generic-function)))
796 (unless (fboundp 'unparse-specializer-using-class)
797 (setf (gdefinition 'unparse-specializer-using-class)
798 (symbol-function 'real-unparse-specializer-using-class)))
800 ;;; a helper function for creating Python-friendly type declarations
801 ;;; in DEFMETHOD forms
802 (defun parameter-specializer-declaration-in-defmethod (parameter specializer)
803 (cond ((and (consp specializer)
804 (eq (car specializer) 'eql))
805 ;; KLUDGE: ANSI, in its wisdom, says that
806 ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
807 ;; DEFMETHOD expansion time. Thus, although one might think
808 ;; that in
809 ;; (DEFMETHOD FOO ((X PACKAGE)
810 ;; (Y (EQL 12))
811 ;; ..))
812 ;; the PACKAGE and (EQL 12) forms are both parallel type
813 ;; names, they're not, as is made clear when you do
814 ;; (DEFMETHOD FOO ((X PACKAGE)
815 ;; (Y (EQL 'BAR)))
816 ;; ..)
817 ;; where Y needs to be a symbol named "BAR", not some cons
818 ;; made by (CONS 'QUOTE 'BAR). I.e. when the
819 ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
820 ;; to be of type (EQL X). It'd be easy to transform one to
821 ;; the other, but it'd be somewhat messier to do so while
822 ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
823 ;; once. (The new code wouldn't be messy, but it'd require a
824 ;; big transformation of the old code.) So instead we punt.
825 ;; -- WHN 20000610
826 '(ignorable))
827 ((member specializer
828 ;; KLUDGE: For some low-level implementation
829 ;; classes, perhaps because of some problems related
830 ;; to the incomplete integration of PCL into SBCL's
831 ;; type system, some specializer classes can't be
832 ;; declared as argument types. E.g.
833 ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
834 ;; (DECLARE (TYPE SLOT-OBJECT X))
835 ;; ..)
836 ;; loses when
837 ;; (DEFSTRUCT BAR A B)
838 ;; (FOO (MAKE-BAR))
839 ;; perhaps because of the way that STRUCTURE-OBJECT
840 ;; inherits both from SLOT-OBJECT and from
841 ;; SB-KERNEL:INSTANCE. In an effort to sweep such
842 ;; problems under the rug, we exclude these problem
843 ;; cases by blacklisting them here. -- WHN 2001-01-19
844 (list 'slot-object #+nil (find-class 'slot-object)))
845 '(ignorable))
846 ((not (eq *boot-state* 'complete))
847 ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
848 ;; types which don't match their specializers. (Specifically,
849 ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
850 ;; second argument.) Hopefully it only does this kind of
851 ;; weirdness when bootstrapping.. -- WHN 20000610
852 '(ignorable))
853 ((typep specializer 'eql-specializer)
854 `(type (eql ,(eql-specializer-object specializer)) ,parameter))
855 ((var-globally-special-p parameter)
856 ;; KLUDGE: Don't declare types for global special variables
857 ;; -- our rebinding magic for SETQ cases don't work right
858 ;; there.
860 ;; FIXME: It would be better to detect the SETQ earlier and
861 ;; skip declarations for specials only when needed, not
862 ;; always.
864 ;; --NS 2004-10-14
865 '(ignorable))
867 ;; Otherwise, we can usually make Python very happy.
869 ;; KLUDGE: Since INFO doesn't work right for class objects here,
870 ;; and they are valid specializers, see if the specializer is
871 ;; a named class, and use the name in that case -- otherwise
872 ;; the class instance is ok, since info will just return NIL, NIL.
874 ;; We still need to deal with the class case too, but at
875 ;; least #.(find-class 'integer) and integer as equivalent
876 ;; specializers with this.
877 (let* ((specializer-nameoid
878 (if (and (typep specializer 'class)
879 (let ((name (class-name specializer)))
880 (and name (symbolp name)
881 (eq specializer (find-class name nil)))))
882 (class-name specializer)
883 specializer))
884 (kind (info :type :kind specializer-nameoid)))
886 (flet ((specializer-nameoid-class ()
887 (typecase specializer-nameoid
888 (symbol (find-class specializer-nameoid nil))
889 (class specializer-nameoid)
890 (class-eq-specializer
891 (specializer-class specializer-nameoid))
892 (t nil))))
893 (ecase kind
894 ((:primitive) `(type ,specializer-nameoid ,parameter))
895 ((:defined)
896 (let ((class (specializer-nameoid-class)))
897 ;; CLASS can be null here if the user has
898 ;; erroneously tried to use a defined type as a
899 ;; specializer; it can be a non-BUILT-IN-CLASS if
900 ;; the user defines a type and calls (SETF
901 ;; FIND-CLASS) in a consistent way.
902 (when (and class (typep class 'built-in-class))
903 `(type ,specializer-nameoid ,parameter))))
904 ((:instance nil)
905 (let ((class (specializer-nameoid-class)))
906 (cond
907 (class
908 (if (typep class '(or built-in-class structure-class))
909 `(type ,class ,parameter)
910 ;; don't declare CLOS classes as parameters;
911 ;; it's too expensive.
912 '(ignorable)))
914 ;; we can get here, and still not have a failure
915 ;; case, by doing MOP programming like (PROGN
916 ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
917 ;; ...)). Best to let the user know we haven't
918 ;; been able to extract enough information:
919 (style-warn
920 "~@<can't find type for specializer ~S in ~S.~@:>"
921 specializer-nameoid
922 'parameter-specializer-declaration-in-defmethod)
923 '(ignorable)))))
924 ((:forthcoming-defclass-type)
925 '(ignorable))))))))
927 ;;; For passing a list (groveled by the walker) of the required
928 ;;; parameters whose bindings are modified in the method body to the
929 ;;; optimized-slot-value* macros.
930 (define-symbol-macro %parameter-binding-modified ())
932 (defmacro simple-lexical-method-functions ((lambda-list
933 method-args
934 next-methods
935 &rest lmf-options)
936 &body body)
937 `(progn
938 ,method-args ,next-methods
939 (bind-simple-lexical-method-functions (,method-args ,next-methods
940 ,lmf-options)
941 (bind-args (,lambda-list ,method-args)
942 ,@body))))
944 (defmacro fast-lexical-method-functions ((lambda-list
945 next-method-call
946 args
947 rest-arg
948 &rest lmf-options)
949 &body body)
950 `(bind-fast-lexical-method-functions (,args ,rest-arg ,next-method-call ,lmf-options)
951 (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
952 ,@body)))
954 (defmacro bind-simple-lexical-method-functions
955 ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
956 closurep applyp method-cell))
957 &body body
958 &environment env)
959 (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
960 `(locally
961 ,@body)
962 `(let ((.next-method. (car ,next-methods))
963 (,next-methods (cdr ,next-methods)))
964 (declare (ignorable .next-method. ,next-methods))
965 (flet (,@(and call-next-method-p
966 `((call-next-method
967 (&rest cnm-args)
968 ,@(if (safe-code-p env)
969 `((%check-cnm-args cnm-args
970 ,method-args
971 ',method-cell))
972 nil)
973 (if .next-method.
974 (funcall (if (std-instance-p .next-method.)
975 (method-function .next-method.)
976 .next-method.) ; for early methods
977 (or cnm-args ,method-args)
978 ,next-methods)
979 (apply #'call-no-next-method
980 ',method-cell
981 (or cnm-args ,method-args))))))
982 ,@(and next-method-p-p
983 '((next-method-p ()
984 (not (null .next-method.))))))
985 ,@body))))
987 (defun call-no-next-method (method-cell &rest args)
988 (let ((method (car method-cell)))
989 (aver method)
990 (apply #'no-next-method (method-generic-function method)
991 method args)))
993 (defstruct (method-call (:copier nil))
994 (function #'identity :type function)
995 call-method-args)
996 (defstruct (constant-method-call (:copier nil) (:include method-call))
997 value)
999 #-sb-fluid (declaim (sb-ext:freeze-type method-call))
1001 (defmacro invoke-method-call1 (function args cm-args)
1002 `(let ((.function. ,function)
1003 (.args. ,args)
1004 (.cm-args. ,cm-args))
1005 (if (and .cm-args. (null (cdr .cm-args.)))
1006 (funcall .function. .args. (car .cm-args.))
1007 (apply .function. .args. .cm-args.))))
1009 (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
1010 `(invoke-method-call1 (method-call-function ,method-call)
1011 ,(if restp
1012 `(list* ,@required-args+rest-arg)
1013 `(list ,@required-args+rest-arg))
1014 (method-call-call-method-args ,method-call)))
1016 (defstruct (fast-method-call (:copier nil))
1017 (function #'identity :type function)
1019 next-method-call
1020 arg-info)
1021 (defstruct (constant-fast-method-call
1022 (:copier nil) (:include fast-method-call))
1023 value)
1025 #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
1027 ;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs
1028 ;; are handled. The first one will get REST-ARG as a single list (as
1029 ;; the last argument), and will thus need to use APPLY. The second one
1030 ;; will get them as a &MORE argument, so we can pass the arguments
1031 ;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES.
1033 (defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
1034 `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
1035 (fast-method-call-pv ,method-call)
1036 (fast-method-call-next-method-call ,method-call)
1037 ,@required-args+rest-arg))
1039 (defmacro invoke-fast-method-call/more (method-call
1040 more-context
1041 more-count
1042 &rest required-args)
1043 (macrolet ((generate-call (n)
1044 ``(funcall (fast-method-call-function ,method-call)
1045 (fast-method-call-pv ,method-call)
1046 (fast-method-call-next-method-call ,method-call)
1047 ,@required-args
1048 ,@(loop for x below ,n
1049 collect `(sb-c::%more-arg ,more-context ,x)))))
1050 ;; The cases with only small amounts of required arguments passed
1051 ;; are probably very common, and special-casing speeds them up by
1052 ;; a factor of 2 with very little effect on the other
1053 ;; cases. Though it'd be nice to have the generic case be equally
1054 ;; fast.
1055 `(case ,more-count
1056 (0 ,(generate-call 0))
1057 (1 ,(generate-call 1))
1058 (t (multiple-value-call (fast-method-call-function ,method-call)
1059 (values (fast-method-call-pv ,method-call))
1060 (values (fast-method-call-next-method-call ,method-call))
1061 ,@required-args
1062 (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
1064 (defstruct (fast-instance-boundp (:copier nil))
1065 (index 0 :type fixnum))
1067 #-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
1069 (eval-when (:compile-toplevel :load-toplevel :execute)
1070 (defvar *allow-emf-call-tracing-p* nil)
1071 (defvar *enable-emf-call-tracing-p* #-sb-show nil #+sb-show t))
1073 ;;;; effective method functions
1075 (defvar *emf-call-trace-size* 200)
1076 (defvar *emf-call-trace* nil)
1077 (defvar *emf-call-trace-index* 0)
1079 ;;; This function was in the CMU CL version of PCL (ca Debian 2.4.8)
1080 ;;; without explanation. It appears to be intended for debugging, so
1081 ;;; it might be useful someday, so I haven't deleted it.
1082 ;;; But it isn't documented and isn't used for anything now, so
1083 ;;; I've conditionalized it out of the base system. -- WHN 19991213
1084 #+sb-show
1085 (defun show-emf-call-trace ()
1086 (when *emf-call-trace*
1087 (let ((j *emf-call-trace-index*)
1088 (*enable-emf-call-tracing-p* nil))
1089 (format t "~&(The oldest entries are printed first)~%")
1090 (dotimes-fixnum (i *emf-call-trace-size*)
1091 (let ((ct (aref *emf-call-trace* j)))
1092 (when ct (print ct)))
1093 (incf j)
1094 (when (= j *emf-call-trace-size*)
1095 (setq j 0))))))
1097 (defun trace-emf-call-internal (emf format args)
1098 (unless *emf-call-trace*
1099 (setq *emf-call-trace* (make-array *emf-call-trace-size*)))
1100 (setf (aref *emf-call-trace* *emf-call-trace-index*)
1101 (list* emf format args))
1102 (incf *emf-call-trace-index*)
1103 (when (= *emf-call-trace-index* *emf-call-trace-size*)
1104 (setq *emf-call-trace-index* 0)))
1106 (defmacro trace-emf-call (emf format args)
1107 (when *allow-emf-call-tracing-p*
1108 `(when *enable-emf-call-tracing-p*
1109 (trace-emf-call-internal ,emf ,format ,args))))
1111 (defmacro invoke-effective-method-function-fast
1112 (emf restp &key required-args rest-arg more-arg)
1113 `(progn
1114 (trace-emf-call ,emf ,restp (list ,@required-args rest-arg))
1115 ,(if more-arg
1116 `(invoke-fast-method-call/more ,emf
1117 ,@more-arg
1118 ,@required-args)
1119 `(invoke-fast-method-call ,emf
1120 ,restp
1121 ,@required-args
1122 ,@rest-arg))))
1124 (defun effective-method-optimized-slot-access-clause
1125 (emf restp required-args)
1126 ;; "What," you may wonder, "do these next two clauses do?" In that
1127 ;; case, you are not a PCL implementor, for they considered this to
1128 ;; be self-documenting.:-| Or CSR, for that matter, since he can
1129 ;; also figure it out by looking at it without breaking stride. For
1130 ;; the rest of us, though: From what the code is doing with .SLOTS.
1131 ;; and whatnot, evidently it's implementing SLOT-VALUEish and
1132 ;; GET-SLOT-VALUEish things. Then we can reason backwards and
1133 ;; conclude that setting EMF to a FIXNUM is an optimized way to
1134 ;; represent these slot access operations.
1135 (when (not restp)
1136 (let ((length (length required-args)))
1137 (cond ((= 1 length)
1138 `((fixnum
1139 (let* ((.slots. (get-slots-or-nil
1140 ,(car required-args)))
1141 (value (when .slots. (clos-slots-ref .slots. ,emf))))
1142 (if (eq value +slot-unbound+)
1143 (slot-unbound-internal ,(car required-args)
1144 ,emf)
1145 value)))))
1146 ((= 2 length)
1147 `((fixnum
1148 (let ((.new-value. ,(car required-args))
1149 (.slots. (get-slots-or-nil
1150 ,(cadr required-args))))
1151 (when .slots.
1152 (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
1153 ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
1154 ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
1155 ;; there was no explanation and presumably the code is 10+
1156 ;; years stale, I simply deleted it. -- WHN)
1159 ;;; Before SBCL 0.9.16.7 instead of
1160 ;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR
1161 ;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now,
1162 ;;; to make less work for the compiler we take a path that doesn't
1163 ;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all.
1164 (macrolet ((def (name &optional narrow)
1165 `(defmacro ,name (emf restp &key required-args rest-arg more-arg)
1166 (unless (constantp restp)
1167 (error "The RESTP argument is not constant."))
1168 (setq restp (constant-form-value restp))
1169 (with-unique-names (emf-n)
1170 `(locally
1171 (declare (optimize (sb-c:insert-step-conditions 0)))
1172 (let ((,emf-n ,emf))
1173 (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg))
1174 (etypecase ,emf-n
1175 (fast-method-call
1176 ,(if more-arg
1177 `(invoke-fast-method-call/more ,emf-n
1178 ,@more-arg
1179 ,@required-args)
1180 `(invoke-fast-method-call ,emf-n
1181 ,restp
1182 ,@required-args
1183 ,@rest-arg)))
1184 ,@,(unless narrow
1185 `(effective-method-optimized-slot-access-clause
1186 emf-n restp required-args))
1187 (method-call
1188 (invoke-method-call ,emf-n ,restp ,@required-args
1189 ,@rest-arg))
1190 (function
1191 ,(if restp
1192 `(apply ,emf-n ,@required-args ,@rest-arg)
1193 `(funcall ,emf-n ,@required-args
1194 ,@rest-arg))))))))))
1195 (def invoke-effective-method-function nil)
1196 (def invoke-narrow-effective-method-function t))
1198 (defun invoke-emf (emf args)
1199 (trace-emf-call emf t args)
1200 (etypecase emf
1201 (fast-method-call
1202 (let* ((arg-info (fast-method-call-arg-info emf))
1203 (restp (cdr arg-info))
1204 (nreq (car arg-info)))
1205 (if restp
1206 (apply (fast-method-call-function emf)
1207 (fast-method-call-pv emf)
1208 (fast-method-call-next-method-call emf)
1209 args)
1210 (cond ((null args)
1211 (if (eql nreq 0)
1212 (invoke-fast-method-call emf nil)
1213 (error 'simple-program-error
1214 :format-control "invalid number of arguments: 0"
1215 :format-arguments nil)))
1216 ((null (cdr args))
1217 (if (eql nreq 1)
1218 (invoke-fast-method-call emf nil (car args))
1219 (error 'simple-program-error
1220 :format-control "invalid number of arguments: 1"
1221 :format-arguments nil)))
1222 ((null (cddr args))
1223 (if (eql nreq 2)
1224 (invoke-fast-method-call emf nil (car args) (cadr args))
1225 (error 'simple-program-error
1226 :format-control "invalid number of arguments: 2"
1227 :format-arguments nil)))
1229 (apply (fast-method-call-function emf)
1230 (fast-method-call-pv emf)
1231 (fast-method-call-next-method-call emf)
1232 args))))))
1233 (method-call
1234 (apply (method-call-function emf)
1235 args
1236 (method-call-call-method-args emf)))
1237 (fixnum
1238 (cond ((null args)
1239 (error 'simple-program-error
1240 :format-control "invalid number of arguments: 0"
1241 :format-arguments nil))
1242 ((null (cdr args))
1243 (let* ((slots (get-slots (car args)))
1244 (value (clos-slots-ref slots emf)))
1245 (if (eq value +slot-unbound+)
1246 (slot-unbound-internal (car args) emf)
1247 value)))
1248 ((null (cddr args))
1249 (setf (clos-slots-ref (get-slots (cadr args)) emf)
1250 (car args)))
1251 (t (error 'simple-program-error
1252 :format-control "invalid number of arguments"
1253 :format-arguments nil))))
1254 (fast-instance-boundp
1255 (if (or (null args) (cdr args))
1256 (error 'simple-program-error
1257 :format-control "invalid number of arguments"
1258 :format-arguments nil)
1259 (let ((slots (get-slots (car args))))
1260 (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf))
1261 +slot-unbound+)))))
1262 (function
1263 (apply emf args))))
1266 (defmacro fast-call-next-method-body ((args next-method-call rest-arg)
1267 method-cell
1268 cnm-args)
1269 `(if ,next-method-call
1270 ,(let ((call `(invoke-narrow-effective-method-function
1271 ,next-method-call
1272 ,(not (null rest-arg))
1273 :required-args ,args
1274 :rest-arg ,(when rest-arg (list rest-arg)))))
1275 `(if ,cnm-args
1276 (bind-args ((,@args
1277 ,@(when rest-arg
1278 `(&rest ,rest-arg)))
1279 ,cnm-args)
1280 ,call)
1281 ,call))
1282 (call-no-next-method ',method-cell
1283 ,@args
1284 ,@(when rest-arg
1285 `(,rest-arg)))))
1287 (defmacro bind-fast-lexical-method-functions
1288 ((args rest-arg next-method-call (&key
1289 call-next-method-p
1290 setq-p
1291 method-cell
1292 next-method-p-p
1293 closurep
1294 applyp))
1295 &body body
1296 &environment env)
1297 (let* ((all-params (append args (when rest-arg (list rest-arg))))
1298 (rebindings (when (or setq-p call-next-method-p)
1299 (mapcar (lambda (x) (list x x)) all-params))))
1300 (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
1301 `(locally
1302 ,@body)
1303 `(flet (,@(when call-next-method-p
1304 `((call-next-method (&rest cnm-args)
1305 (declare (muffle-conditions code-deletion-note)
1306 (optimize (sb-c:insert-step-conditions 0)))
1307 ,@(if (safe-code-p env)
1308 `((%check-cnm-args cnm-args (list ,@args)
1309 ',method-cell))
1310 nil)
1311 (fast-call-next-method-body (,args
1312 ,next-method-call
1313 ,rest-arg)
1314 ,method-cell
1315 cnm-args))))
1316 ,@(when next-method-p-p
1317 `((next-method-p ()
1318 (declare (optimize (sb-c:insert-step-conditions 0)))
1319 (not (null ,next-method-call))))))
1320 (let ,rebindings
1321 ,@(when rebindings `((declare (ignorable ,@all-params))))
1322 ,@body)))))
1324 ;;; CMUCL comment (Gerd Moellmann):
1326 ;;; The standard says it's an error if CALL-NEXT-METHOD is called with
1327 ;;; arguments, and the set of methods applicable to those arguments is
1328 ;;; different from the set of methods applicable to the original
1329 ;;; method arguments. (According to Barry Margolin, this rule was
1330 ;;; probably added to ensure that before and around methods are always
1331 ;;; run before primary methods.)
1333 ;;; This could be optimized for the case that the generic function
1334 ;;; doesn't have hairy methods, does have standard method combination,
1335 ;;; is a standard generic function, there are no methods defined on it
1336 ;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such
1337 ;;; preconditions. That looks hairy and is probably not worth it,
1338 ;;; because this check will never be fast.
1339 (defun %check-cnm-args (cnm-args orig-args method-cell)
1340 (when cnm-args
1341 (let* ((gf (method-generic-function (car method-cell)))
1342 (omethods (compute-applicable-methods gf orig-args))
1343 (nmethods (compute-applicable-methods gf cnm-args)))
1344 (unless (equal omethods nmethods)
1345 (error "~@<The set of methods ~S applicable to argument~P ~
1346 ~{~S~^, ~} to call-next-method is different from ~
1347 the set of methods ~S applicable to the original ~
1348 method argument~P ~{~S~^, ~}.~@:>"
1349 nmethods (length cnm-args) cnm-args omethods
1350 (length orig-args) orig-args)))))
1352 (defmacro bind-args ((lambda-list args) &body body)
1353 (let ((args-tail '.args-tail.)
1354 (key '.key.)
1355 (state 'required))
1356 (flet ((process-var (var)
1357 (if (memq var lambda-list-keywords)
1358 (progn
1359 (case var
1360 (&optional (setq state 'optional))
1361 (&key (setq state 'key))
1362 (&allow-other-keys)
1363 (&rest (setq state 'rest))
1364 (&aux (setq state 'aux))
1365 (otherwise
1366 (error
1367 "encountered the non-standard lambda list keyword ~S"
1368 var)))
1369 nil)
1370 (case state
1371 (required `((,var (pop ,args-tail))))
1372 (optional (cond ((not (consp var))
1373 `((,var (when ,args-tail
1374 (pop ,args-tail)))))
1375 ((null (cddr var))
1376 `((,(car var) (if ,args-tail
1377 (pop ,args-tail)
1378 ,(cadr var)))))
1380 `((,(caddr var) (not (null ,args-tail)))
1381 (,(car var) (if ,args-tail
1382 (pop ,args-tail)
1383 ,(cadr var)))))))
1384 (rest `((,var ,args-tail)))
1385 (key (cond ((not (consp var))
1386 `((,var (car
1387 (get-key-arg-tail ,(keywordicate var)
1388 ,args-tail)))))
1389 ((null (cddr var))
1390 (multiple-value-bind (keyword variable)
1391 (if (consp (car var))
1392 (values (caar var)
1393 (cadar var))
1394 (values (keywordicate (car var))
1395 (car var)))
1396 `((,key (get-key-arg-tail ',keyword
1397 ,args-tail))
1398 (,variable (if ,key
1399 (car ,key)
1400 ,(cadr var))))))
1402 (multiple-value-bind (keyword variable)
1403 (if (consp (car var))
1404 (values (caar var)
1405 (cadar var))
1406 (values (keywordicate (car var))
1407 (car var)))
1408 `((,key (get-key-arg-tail ',keyword
1409 ,args-tail))
1410 (,(caddr var) (not (null,key)))
1411 (,variable (if ,key
1412 (car ,key)
1413 ,(cadr var))))))))
1414 (aux `(,var))))))
1415 (let ((bindings (mapcan #'process-var lambda-list)))
1416 `(let* ((,args-tail ,args)
1417 ,@bindings
1418 (.dummy0.
1419 ,@(when (eq state 'optional)
1420 `((unless (null ,args-tail)
1421 (error 'simple-program-error
1422 :format-control "surplus arguments: ~S"
1423 :format-arguments (list ,args-tail)))))))
1424 (declare (ignorable ,args-tail .dummy0.))
1425 ,@body)))))
1427 (defun get-key-arg-tail (keyword list)
1428 (loop for (key . tail) on list by #'cddr
1429 when (null tail) do
1430 ;; FIXME: Do we want to export this symbol? Or maybe use an
1431 ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form?
1432 (sb-c::%odd-key-args-error)
1433 when (eq key keyword)
1434 return tail))
1436 (defun walk-method-lambda (method-lambda required-parameters env slots)
1437 (let (;; flag indicating that CALL-NEXT-METHOD should be in the
1438 ;; method definition
1439 (call-next-method-p nil)
1440 ;; flag indicating that #'CALL-NEXT-METHOD was seen in the
1441 ;; body of a method
1442 (closurep nil)
1443 ;; flag indicating that NEXT-METHOD-P should be in the method
1444 ;; definition
1445 (next-method-p-p nil)
1446 ;; a list of all required parameters whose bindings might be
1447 ;; modified in the method body.
1448 (parameters-setqd nil))
1449 (flet ((walk-function (form context env)
1450 (cond ((not (eq context :eval)) form)
1451 ;; FIXME: Jumping to a conclusion from the way it's used
1452 ;; above, perhaps CONTEXT should be called SITUATION
1453 ;; (after the term used in the ANSI specification of
1454 ;; EVAL-WHEN) and given modern ANSI keyword values
1455 ;; like :LOAD-TOPLEVEL.
1456 ((not (listp form)) form)
1457 ((eq (car form) 'call-next-method)
1458 (setq call-next-method-p t)
1459 form)
1460 ((eq (car form) 'next-method-p)
1461 (setq next-method-p-p t)
1462 form)
1463 ((memq (car form) '(setq multiple-value-setq))
1464 ;; FIXME: this is possibly a little strong as
1465 ;; conditions go. Ideally we would want to detect
1466 ;; which, if any, of the method parameters are
1467 ;; being set, and communicate that information to
1468 ;; e.g. SPLIT-DECLARATIONS. However, the brute
1469 ;; force method doesn't really cost much; a little
1470 ;; loss of discrimination over IGNORED variables
1471 ;; should be all. -- CSR, 2004-07-01
1473 ;; As of 2006-09-18 modified parameter bindings
1474 ;; are now tracked with more granularity than just
1475 ;; one SETQ-P flag, in order to disable SLOT-VALUE
1476 ;; optimizations for parameters that are SETQd.
1477 ;; The old binary SETQ-P flag is still used for
1478 ;; all other purposes, since as noted above, the
1479 ;; extra cost is minimal. -- JES, 2006-09-18
1481 ;; The walker will split (SETQ A 1 B 2) to
1482 ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
1483 ;; only need to handle the simple case of SETQ
1484 ;; here.
1485 (let ((vars (if (eq (car form) 'setq)
1486 (list (second form))
1487 (second form))))
1488 (dolist (var vars)
1489 ;; Note that we don't need to check for
1490 ;; %VARIABLE-REBINDING declarations like is
1491 ;; done in CAN-OPTIMIZE-ACCESS1, since the
1492 ;; bindings that will have that declation will
1493 ;; never be SETQd.
1494 (when (var-declaration '%class var env)
1495 ;; If a parameter binding is shadowed by
1496 ;; another binding it won't have a %CLASS
1497 ;; declaration anymore, and this won't get
1498 ;; executed.
1499 (pushnew var parameters-setqd))))
1500 form)
1501 ((and (eq (car form) 'function)
1502 (cond ((eq (cadr form) 'call-next-method)
1503 (setq call-next-method-p t)
1504 (setq closurep t)
1505 form)
1506 ((eq (cadr form) 'next-method-p)
1507 (setq next-method-p-p t)
1508 (setq closurep t)
1509 form)
1510 (t nil))))
1511 ((and (memq (car form)
1512 '(slot-value set-slot-value slot-boundp))
1513 (constantp (caddr form) env))
1514 (let ((fun (ecase (car form)
1515 (slot-value #'optimize-slot-value)
1516 (set-slot-value #'optimize-set-slot-value)
1517 (slot-boundp #'optimize-slot-boundp))))
1518 (funcall fun form slots required-parameters env)))
1519 (t form))))
1521 (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
1522 ;;; FIXME: the walker's rewriting of the source code causes
1523 ;;; trouble when doing code coverage. The rewrites should be
1524 ;;; removed, and the same operations done using
1525 ;;; compiler-macros or tranforms.
1526 (values (if (sb-c:policy env (= sb-c:store-coverage-data 0))
1527 walked-lambda
1528 method-lambda)
1529 call-next-method-p
1530 closurep
1531 next-method-p-p
1532 (not (null parameters-setqd))
1533 parameters-setqd)))))
1535 (defun generic-function-name-p (name)
1536 (and (legal-fun-name-p name)
1537 (fboundp name)
1538 (if (eq *boot-state* 'complete)
1539 (standard-generic-function-p (gdefinition name))
1540 (funcallable-instance-p (gdefinition name)))))
1542 (defun method-plist-value (method key &optional default)
1543 (let ((plist (if (consp method)
1544 (getf (early-method-initargs method) 'plist)
1545 (object-plist method))))
1546 (getf plist key default)))
1548 (defun (setf method-plist-value) (new-value method key &optional default)
1549 (if (consp method)
1550 (setf (getf (getf (early-method-initargs method) 'plist) key default)
1551 new-value)
1552 (setf (getf (object-plist method) key default) new-value)))
1554 (defun load-defmethod (class name quals specls ll initargs source-location)
1555 (let ((method-cell (getf initargs 'method-cell)))
1556 (setq initargs (copy-tree initargs))
1557 (when method-cell
1558 (setf (getf initargs 'method-cell) method-cell))
1559 #+nil
1560 (setf (getf (getf initargs 'plist) :name)
1561 (make-method-spec name quals specls))
1562 (load-defmethod-internal class name quals specls
1563 ll initargs source-location)))
1565 (defun load-defmethod-internal
1566 (method-class gf-spec qualifiers specializers lambda-list
1567 initargs source-location)
1568 (when (and (eq *boot-state* 'complete)
1569 (fboundp gf-spec))
1570 (let* ((gf (fdefinition gf-spec))
1571 (method (and (generic-function-p gf)
1572 (generic-function-methods gf)
1573 (find-method gf qualifiers specializers nil))))
1574 (when method
1575 (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
1576 gf-spec qualifiers specializers))))
1577 (let ((method (apply #'add-named-method
1578 gf-spec qualifiers specializers lambda-list
1579 :definition-source source-location
1580 initargs)))
1581 (unless (or (eq method-class 'standard-method)
1582 (eq (find-class method-class nil) (class-of method)))
1583 ;; FIXME: should be STYLE-WARNING?
1584 (format *error-output*
1585 "~&At the time the method with qualifiers ~:S and~%~
1586 specializers ~:S on the generic function ~S~%~
1587 was compiled, the method-class for that generic function was~%~
1588 ~S. But, the method class is now ~S, this~%~
1589 may mean that this method was compiled improperly.~%"
1590 qualifiers specializers gf-spec
1591 method-class (class-name (class-of method))))
1592 method))
1594 (defun make-method-spec (gf qualifiers specializers)
1595 (let ((name (generic-function-name gf))
1596 (unparsed-specializers (unparse-specializers gf specializers)))
1597 `(slow-method ,name ,@qualifiers ,unparsed-specializers)))
1599 (defun initialize-method-function (initargs method)
1600 (let* ((mf (getf initargs :function))
1601 (mff (and (typep mf '%method-function)
1602 (%method-function-fast-function mf)))
1603 (plist (getf initargs 'plist))
1604 (name (getf plist :name))
1605 (method-cell (getf initargs 'method-cell)))
1606 (when method-cell
1607 (setf (car method-cell) method))
1608 (when name
1609 (when mf
1610 (setq mf (set-fun-name mf name)))
1611 (when (and mff (consp name) (eq (car name) 'slow-method))
1612 (let ((fast-name `(fast-method ,@(cdr name))))
1613 (set-fun-name mff fast-name))))
1614 (when plist
1615 (let ((plist plist))
1616 (let ((snl (getf plist :slot-name-lists)))
1617 (when snl
1618 (setf (method-plist-value method :pv-table)
1619 (intern-pv-table :slot-name-lists snl))))))))
1621 (defun analyze-lambda-list (lambda-list)
1622 (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
1623 (parse-key-arg (arg)
1624 (if (listp arg)
1625 (if (listp (car arg))
1626 (caar arg)
1627 (keywordicate (car arg)))
1628 (keywordicate arg))))
1629 (let ((nrequired 0)
1630 (noptional 0)
1631 (keysp nil)
1632 (restp nil)
1633 (nrest 0)
1634 (allow-other-keys-p nil)
1635 (keywords ())
1636 (keyword-parameters ())
1637 (state 'required))
1638 (dolist (x lambda-list)
1639 (if (memq x lambda-list-keywords)
1640 (case x
1641 (&optional (setq state 'optional))
1642 (&key (setq keysp t
1643 state 'key))
1644 (&allow-other-keys (setq allow-other-keys-p t))
1645 (&rest (setq restp t
1646 state 'rest))
1647 (&aux (return t))
1648 (otherwise
1649 (error "encountered the non-standard lambda list keyword ~S"
1650 x)))
1651 (ecase state
1652 (required (incf nrequired))
1653 (optional (incf noptional))
1654 (key (push (parse-key-arg x) keywords)
1655 (push x keyword-parameters))
1656 (rest (incf nrest)))))
1657 (when (and restp (zerop nrest))
1658 (error "Error in lambda-list:~%~
1659 After &REST, a DEFGENERIC lambda-list ~
1660 must be followed by at least one variable."))
1661 (values nrequired noptional keysp restp allow-other-keys-p
1662 (reverse keywords)
1663 (reverse keyword-parameters)))))
1665 (defun keyword-spec-name (x)
1666 (let ((key (if (atom x) x (car x))))
1667 (if (atom key)
1668 (keywordicate key)
1669 (car key))))
1671 (defun ftype-declaration-from-lambda-list (lambda-list name)
1672 (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
1673 keywords keyword-parameters)
1674 (analyze-lambda-list lambda-list)
1675 (declare (ignore keyword-parameters))
1676 (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
1677 (old-ftype (if (fun-type-p old) old nil))
1678 (old-restp (and old-ftype (fun-type-rest old-ftype)))
1679 (old-keys (and old-ftype
1680 (mapcar #'key-info-name
1681 (fun-type-keywords
1682 old-ftype))))
1683 (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
1684 (old-allowp (and old-ftype
1685 (fun-type-allowp old-ftype)))
1686 (keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
1687 `(function ,(append (make-list nrequired :initial-element t)
1688 (when (plusp noptional)
1689 (append '(&optional)
1690 (make-list noptional :initial-element t)))
1691 (when (or restp old-restp)
1692 '(&rest t))
1693 (when (or keysp old-keysp)
1694 (append '(&key)
1695 (mapcar (lambda (key)
1696 `(,key t))
1697 keywords)
1698 (when (or allow-other-keys-p old-allowp)
1699 '(&allow-other-keys)))))
1700 *))))
1702 (defun defgeneric-declaration (spec lambda-list)
1703 `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
1705 ;;;; early generic function support
1707 (defvar *!early-generic-functions* ())
1709 (defun ensure-generic-function (fun-name
1710 &rest all-keys
1711 &key environment source-location
1712 &allow-other-keys)
1713 (declare (ignore environment))
1714 (let ((existing (and (fboundp fun-name)
1715 (gdefinition fun-name))))
1716 (cond ((and existing
1717 (eq *boot-state* 'complete)
1718 (null (generic-function-p existing)))
1719 (generic-clobbers-function fun-name)
1720 (fmakunbound fun-name)
1721 (apply #'ensure-generic-function fun-name all-keys))
1723 (apply #'ensure-generic-function-using-class
1724 existing fun-name all-keys)))))
1726 (defun generic-clobbers-function (fun-name)
1727 (cerror "Replace the function binding"
1728 'simple-program-error
1729 :format-control "~S already names an ordinary function or a macro."
1730 :format-arguments (list fun-name)))
1732 (defvar *sgf-wrapper*
1733 (boot-make-wrapper (early-class-size 'standard-generic-function)
1734 'standard-generic-function))
1736 (defvar *sgf-slots-init*
1737 (mapcar (lambda (canonical-slot)
1738 (if (memq (getf canonical-slot :name) '(arg-info source))
1739 +slot-unbound+
1740 (let ((initfunction (getf canonical-slot :initfunction)))
1741 (if initfunction
1742 (funcall initfunction)
1743 +slot-unbound+))))
1744 (early-collect-inheritance 'standard-generic-function)))
1746 (defvar *sgf-method-class-index*
1747 (!bootstrap-slot-index 'standard-generic-function 'method-class))
1749 (defun early-gf-p (x)
1750 (and (fsc-instance-p x)
1751 (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
1752 +slot-unbound+)))
1754 (defvar *sgf-methods-index*
1755 (!bootstrap-slot-index 'standard-generic-function 'methods))
1757 (defmacro early-gf-methods (gf)
1758 `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
1760 (defun safe-generic-function-methods (generic-function)
1761 (if (eq (class-of generic-function) *the-class-standard-generic-function*)
1762 (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
1763 (generic-function-methods generic-function)))
1765 (defvar *sgf-arg-info-index*
1766 (!bootstrap-slot-index 'standard-generic-function 'arg-info))
1768 (defmacro early-gf-arg-info (gf)
1769 `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
1771 (defvar *sgf-dfun-state-index*
1772 (!bootstrap-slot-index 'standard-generic-function 'dfun-state))
1774 (defstruct (arg-info
1775 (:conc-name nil)
1776 (:constructor make-arg-info ())
1777 (:copier nil))
1778 (arg-info-lambda-list :no-lambda-list)
1779 arg-info-precedence
1780 arg-info-metatypes
1781 arg-info-number-optional
1782 arg-info-key/rest-p
1783 arg-info-keys ;nil no &KEY or &REST allowed
1784 ;(k1 k2 ..) Each method must accept these &KEY arguments.
1785 ;T must have &KEY or &REST
1787 gf-info-simple-accessor-type ; nil, reader, writer, boundp
1788 (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
1790 gf-info-static-c-a-m-emf
1791 (gf-info-c-a-m-emf-std-p t)
1792 gf-info-fast-mf-p)
1794 #-sb-fluid (declaim (sb-ext:freeze-type arg-info))
1796 (defun arg-info-valid-p (arg-info)
1797 (not (null (arg-info-number-optional arg-info))))
1799 (defun arg-info-applyp (arg-info)
1800 (or (plusp (arg-info-number-optional arg-info))
1801 (arg-info-key/rest-p arg-info)))
1803 (defun arg-info-number-required (arg-info)
1804 (length (arg-info-metatypes arg-info)))
1806 (defun arg-info-nkeys (arg-info)
1807 (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
1809 (defun create-gf-lambda-list (lambda-list)
1810 ;;; Create a gf lambda list from a method lambda list
1811 (loop for x in lambda-list
1812 collect (if (consp x) (list (car x)) x)
1813 if (eq x '&key) do (loop-finish)))
1815 (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
1816 argument-precedence-order)
1817 (let* ((arg-info (if (eq *boot-state* 'complete)
1818 (gf-arg-info gf)
1819 (early-gf-arg-info gf)))
1820 (methods (if (eq *boot-state* 'complete)
1821 (generic-function-methods gf)
1822 (early-gf-methods gf)))
1823 (was-valid-p (integerp (arg-info-number-optional arg-info)))
1824 (first-p (and new-method (null (cdr methods)))))
1825 (when (and (not lambda-list-p) methods)
1826 (setq lambda-list (gf-lambda-list gf)))
1827 (when (or lambda-list-p
1828 (and first-p
1829 (eq (arg-info-lambda-list arg-info) :no-lambda-list)))
1830 (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1831 (analyze-lambda-list lambda-list)
1832 (when (and methods (not first-p))
1833 (let ((gf-nreq (arg-info-number-required arg-info))
1834 (gf-nopt (arg-info-number-optional arg-info))
1835 (gf-key/rest-p (arg-info-key/rest-p arg-info)))
1836 (unless (and (= nreq gf-nreq)
1837 (= nopt gf-nopt)
1838 (eq (or keysp restp) gf-key/rest-p))
1839 (error "The lambda-list ~S is incompatible with ~
1840 existing methods of ~S."
1841 lambda-list gf))))
1842 (setf (arg-info-lambda-list arg-info)
1843 (if lambda-list-p
1844 lambda-list
1845 (create-gf-lambda-list lambda-list)))
1846 (when (or lambda-list-p argument-precedence-order
1847 (null (arg-info-precedence arg-info)))
1848 (setf (arg-info-precedence arg-info)
1849 (compute-precedence lambda-list nreq argument-precedence-order)))
1850 (setf (arg-info-metatypes arg-info) (make-list nreq))
1851 (setf (arg-info-number-optional arg-info) nopt)
1852 (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
1853 (setf (arg-info-keys arg-info)
1854 (if lambda-list-p
1855 (if allow-other-keys-p t keywords)
1856 (arg-info-key/rest-p arg-info)))))
1857 (when new-method
1858 (check-method-arg-info gf arg-info new-method))
1859 (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
1860 arg-info))
1862 (defun check-method-arg-info (gf arg-info method)
1863 (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1864 (analyze-lambda-list (if (consp method)
1865 (early-method-lambda-list method)
1866 (method-lambda-list method)))
1867 (flet ((lose (string &rest args)
1868 (error 'simple-program-error
1869 :format-control "~@<attempt to add the method~2I~_~S~I~_~
1870 to the generic function~2I~_~S;~I~_~
1871 but ~?~:>"
1872 :format-arguments (list method gf string args)))
1873 (comparison-description (x y)
1874 (if (> x y) "more" "fewer")))
1875 (let ((gf-nreq (arg-info-number-required arg-info))
1876 (gf-nopt (arg-info-number-optional arg-info))
1877 (gf-key/rest-p (arg-info-key/rest-p arg-info))
1878 (gf-keywords (arg-info-keys arg-info)))
1879 (unless (= nreq gf-nreq)
1880 (lose
1881 "the method has ~A required arguments than the generic function."
1882 (comparison-description nreq gf-nreq)))
1883 (unless (= nopt gf-nopt)
1884 (lose
1885 "the method has ~A optional arguments than the generic function."
1886 (comparison-description nopt gf-nopt)))
1887 (unless (eq (or keysp restp) gf-key/rest-p)
1888 (lose
1889 "the method and generic function differ in whether they accept~_~
1890 &REST or &KEY arguments."))
1891 (when (consp gf-keywords)
1892 (unless (or (and restp (not keysp))
1893 allow-other-keys-p
1894 (every (lambda (k) (memq k keywords)) gf-keywords))
1895 (lose "the method does not accept each of the &KEY arguments~2I~_~
1896 ~S."
1897 gf-keywords)))))))
1899 (defvar *sm-specializers-index*
1900 (!bootstrap-slot-index 'standard-method 'specializers))
1901 (defvar *sm-%function-index*
1902 (!bootstrap-slot-index 'standard-method '%function))
1903 (defvar *sm-qualifiers-index*
1904 (!bootstrap-slot-index 'standard-method 'qualifiers))
1905 (defvar *sm-plist-index*
1906 (!bootstrap-slot-index 'standard-method 'plist))
1908 ;;; FIXME: we don't actually need this; we could test for the exact
1909 ;;; class and deal with it as appropriate. In fact we probably don't
1910 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
1911 ;;; the standard reader method for METHOD-SPECIALIZERS. Probably.
1912 (dolist (s '(specializers %function plist))
1913 (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
1914 (!bootstrap-slot-index 'standard-reader-method s)
1915 (!bootstrap-slot-index 'standard-writer-method s)
1916 (!bootstrap-slot-index 'standard-boundp-method s))))
1918 (defun safe-method-specializers (method)
1919 (let ((standard-method-classes
1920 (list *the-class-standard-method*
1921 *the-class-standard-reader-method*
1922 *the-class-standard-writer-method*
1923 *the-class-standard-boundp-method*))
1924 (class (class-of method)))
1925 (if (member class standard-method-classes)
1926 (clos-slots-ref (get-slots method) *sm-specializers-index*)
1927 (method-specializers method))))
1928 (defun safe-method-fast-function (method)
1929 (let ((mf (safe-method-function method)))
1930 (and (typep mf '%method-function)
1931 (%method-function-fast-function mf))))
1932 (defun safe-method-function (method)
1933 (let ((standard-method-classes
1934 (list *the-class-standard-method*
1935 *the-class-standard-reader-method*
1936 *the-class-standard-writer-method*
1937 *the-class-standard-boundp-method*))
1938 (class (class-of method)))
1939 (if (member class standard-method-classes)
1940 (clos-slots-ref (get-slots method) *sm-%function-index*)
1941 (method-function method))))
1942 (defun safe-method-qualifiers (method)
1943 (let ((standard-method-classes
1944 (list *the-class-standard-method*
1945 *the-class-standard-reader-method*
1946 *the-class-standard-writer-method*
1947 *the-class-standard-boundp-method*))
1948 (class (class-of method)))
1949 (if (member class standard-method-classes)
1950 (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
1951 (method-qualifiers method))))
1953 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
1954 (let* ((existing-p (and methods (cdr methods) new-method))
1955 (nreq (length (arg-info-metatypes arg-info)))
1956 (metatypes (if existing-p
1957 (arg-info-metatypes arg-info)
1958 (make-list nreq)))
1959 (type (if existing-p
1960 (gf-info-simple-accessor-type arg-info)
1961 nil)))
1962 (when (arg-info-valid-p arg-info)
1963 (dolist (method (if new-method (list new-method) methods))
1964 (let* ((specializers (if (or (eq *boot-state* 'complete)
1965 (not (consp method)))
1966 (safe-method-specializers method)
1967 (early-method-specializers method t)))
1968 (class (if (or (eq *boot-state* 'complete) (not (consp method)))
1969 (class-of method)
1970 (early-method-class method)))
1971 (new-type
1972 (when (and class
1973 (or (not (eq *boot-state* 'complete))
1974 (eq (generic-function-method-combination gf)
1975 *standard-method-combination*)))
1976 (cond ((or (eq class *the-class-standard-reader-method*)
1977 (eq class *the-class-global-reader-method*))
1978 'reader)
1979 ((or (eq class *the-class-standard-writer-method*)
1980 (eq class *the-class-global-writer-method*))
1981 'writer)
1982 ((or (eq class *the-class-standard-boundp-method*)
1983 (eq class *the-class-global-boundp-method*))
1984 'boundp)))))
1985 (setq metatypes (mapcar #'raise-metatype metatypes specializers))
1986 (setq type (cond ((null type) new-type)
1987 ((eq type new-type) type)
1988 (t nil)))))
1989 (setf (arg-info-metatypes arg-info) metatypes)
1990 (setf (gf-info-simple-accessor-type arg-info) type)))
1991 (when (or (not was-valid-p) first-p)
1992 (multiple-value-bind (c-a-m-emf std-p)
1993 (if (early-gf-p gf)
1994 (values t t)
1995 (compute-applicable-methods-emf gf))
1996 (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
1997 (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
1998 (unless (gf-info-c-a-m-emf-std-p arg-info)
1999 (setf (gf-info-simple-accessor-type arg-info) t))))
2000 (unless was-valid-p
2001 (let ((name (if (eq *boot-state* 'complete)
2002 (generic-function-name gf)
2003 (!early-gf-name gf))))
2004 (setf (gf-precompute-dfun-and-emf-p arg-info)
2005 (cond
2006 ((and (consp name)
2007 (member (car name)
2008 *internal-pcl-generalized-fun-name-symbols*))
2009 nil)
2010 (t (let* ((symbol (fun-name-block-name name))
2011 (package (symbol-package symbol)))
2012 (and (or (eq package *pcl-package*)
2013 (memq package (package-use-list *pcl-package*)))
2014 ;; FIXME: this test will eventually be
2015 ;; superseded by the *internal-pcl...* test,
2016 ;; above. While we are in a process of
2017 ;; transition, however, it should probably
2018 ;; remain.
2019 (not (find #\Space (symbol-name symbol))))))))))
2020 (setf (gf-info-fast-mf-p arg-info)
2021 (or (not (eq *boot-state* 'complete))
2022 (let* ((method-class (generic-function-method-class gf))
2023 (methods (compute-applicable-methods
2024 #'make-method-lambda
2025 (list gf (class-prototype method-class)
2026 '(lambda) nil))))
2027 (and methods (null (cdr methods))
2028 (let ((specls (method-specializers (car methods))))
2029 (and (classp (car specls))
2030 (eq 'standard-generic-function
2031 (class-name (car specls)))
2032 (classp (cadr specls))
2033 (eq 'standard-method
2034 (class-name (cadr specls)))))))))
2035 arg-info)
2037 ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
2039 ;;; The STATIC-SLOTS field of the funcallable instances used as early
2040 ;;; generic functions is used to store the early methods and early
2041 ;;; discriminator code for the early generic function. The static
2042 ;;; slots field of the fins contains a list whose:
2043 ;;; CAR - a list of the early methods on this early gf
2044 ;;; CADR - the early discriminator code for this method
2045 (defun ensure-generic-function-using-class (existing spec &rest keys
2046 &key (lambda-list nil
2047 lambda-list-p)
2048 argument-precedence-order
2049 source-location
2050 documentation
2051 &allow-other-keys)
2052 (declare (ignore keys))
2053 (cond ((and existing (early-gf-p existing))
2054 (when lambda-list-p
2055 (set-arg-info existing :lambda-list lambda-list))
2056 existing)
2057 ((assoc spec *!generic-function-fixups* :test #'equal)
2058 (if existing
2059 (make-early-gf spec lambda-list lambda-list-p existing
2060 argument-precedence-order source-location
2061 documentation)
2062 (bug "The function ~S is not already defined." spec)))
2063 (existing
2064 (bug "~S should be on the list ~S."
2065 spec '*!generic-function-fixups*))
2067 (pushnew spec *!early-generic-functions* :test #'equal)
2068 (make-early-gf spec lambda-list lambda-list-p nil
2069 argument-precedence-order source-location
2070 documentation))))
2072 (defun make-early-gf (spec &optional lambda-list lambda-list-p
2073 function argument-precedence-order source-location
2074 documentation)
2075 (let ((fin (allocate-standard-funcallable-instance
2076 *sgf-wrapper* *sgf-slots-init*)))
2077 (set-funcallable-instance-function
2079 (or function
2080 (if (eq spec 'print-object)
2081 #'(lambda (instance stream)
2082 (print-unreadable-object (instance stream :identity t)
2083 (format stream "std-instance")))
2084 #'(lambda (&rest args)
2085 (declare (ignore args))
2086 (error "The function of the funcallable-instance ~S~
2087 has not been set." fin)))))
2088 (setf (gdefinition spec) fin)
2089 (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
2090 (!bootstrap-set-slot 'standard-generic-function fin
2091 'source source-location)
2092 (!bootstrap-set-slot 'standard-generic-function fin
2093 '%documentation documentation)
2094 (set-fun-name fin spec)
2095 (let ((arg-info (make-arg-info)))
2096 (setf (early-gf-arg-info fin) arg-info)
2097 (when lambda-list-p
2098 (proclaim (defgeneric-declaration spec lambda-list))
2099 (if argument-precedence-order
2100 (set-arg-info fin
2101 :lambda-list lambda-list
2102 :argument-precedence-order argument-precedence-order)
2103 (set-arg-info fin :lambda-list lambda-list))))
2104 fin))
2106 (defun safe-gf-dfun-state (generic-function)
2107 (if (eq (class-of generic-function) *the-class-standard-generic-function*)
2108 (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
2109 (gf-dfun-state generic-function)))
2110 (defun (setf safe-gf-dfun-state) (new-value generic-function)
2111 (if (eq (class-of generic-function) *the-class-standard-generic-function*)
2112 (setf (clos-slots-ref (get-slots generic-function)
2113 *sgf-dfun-state-index*)
2114 new-value)
2115 (setf (gf-dfun-state generic-function) new-value)))
2117 (defun set-dfun (gf &optional dfun cache info)
2118 (let ((new-state (if (and dfun (or cache info))
2119 (list* dfun cache info)
2120 dfun)))
2121 (cond
2122 ((eq *boot-state* 'complete)
2123 ;; Check that we are under the lock.
2124 #+sb-thread
2125 (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf))))
2126 (setf (safe-gf-dfun-state gf) new-state))
2128 (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
2129 new-state))))
2130 dfun)
2132 (defun gf-dfun-cache (gf)
2133 (let ((state (if (eq *boot-state* 'complete)
2134 (safe-gf-dfun-state gf)
2135 (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
2136 (typecase state
2137 (function nil)
2138 (cons (cadr state)))))
2140 (defun gf-dfun-info (gf)
2141 (let ((state (if (eq *boot-state* 'complete)
2142 (safe-gf-dfun-state gf)
2143 (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
2144 (typecase state
2145 (function nil)
2146 (cons (cddr state)))))
2148 (defvar *sgf-name-index*
2149 (!bootstrap-slot-index 'standard-generic-function 'name))
2151 (defun !early-gf-name (gf)
2152 (clos-slots-ref (get-slots gf) *sgf-name-index*))
2154 (defun gf-lambda-list (gf)
2155 (let ((arg-info (if (eq *boot-state* 'complete)
2156 (gf-arg-info gf)
2157 (early-gf-arg-info gf))))
2158 (if (eq :no-lambda-list (arg-info-lambda-list arg-info))
2159 (let ((methods (if (eq *boot-state* 'complete)
2160 (generic-function-methods gf)
2161 (early-gf-methods gf))))
2162 (if (null methods)
2163 (progn
2164 (warn "no way to determine the lambda list for ~S" gf)
2165 nil)
2166 (let* ((method (car (last methods)))
2167 (ll (if (consp method)
2168 (early-method-lambda-list method)
2169 (method-lambda-list method))))
2170 (create-gf-lambda-list ll))))
2171 (arg-info-lambda-list arg-info))))
2173 (defmacro real-ensure-gf-internal (gf-class all-keys env)
2174 `(progn
2175 (cond ((symbolp ,gf-class)
2176 (setq ,gf-class (find-class ,gf-class t ,env)))
2177 ((classp ,gf-class))
2179 (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
2180 class nor a symbol that names a class."
2181 ,gf-class)))
2182 (unless (class-finalized-p ,gf-class)
2183 (if (class-has-a-forward-referenced-superclass-p ,gf-class)
2184 ;; FIXME: reference MOP documentation -- this is an
2185 ;; additional requirement on our users
2186 (error "The generic function class ~S is not finalizeable" ,gf-class)
2187 (finalize-inheritance ,gf-class)))
2188 (remf ,all-keys :generic-function-class)
2189 (remf ,all-keys :environment)
2190 (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
2191 (unless (eq combin '.shes-not-there.)
2192 (setf (getf ,all-keys :method-combination)
2193 (find-method-combination (class-prototype ,gf-class)
2194 (car combin)
2195 (cdr combin)))))
2196 (let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
2197 (unless (eq method-class '.shes-not-there.)
2198 (setf (getf ,all-keys :method-class)
2199 (cond ((classp method-class)
2200 method-class)
2201 (t (find-class method-class t ,env))))))))
2203 (defun real-ensure-gf-using-class--generic-function
2204 (existing
2205 fun-name
2206 &rest all-keys
2207 &key environment (lambda-list nil lambda-list-p)
2208 (generic-function-class 'standard-generic-function)
2209 &allow-other-keys)
2210 (real-ensure-gf-internal generic-function-class all-keys environment)
2211 ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS,
2212 ;; which is what makes the next line work
2213 (unless (eq (class-of existing) generic-function-class)
2214 (change-class existing generic-function-class))
2215 (prog1
2216 (apply #'reinitialize-instance existing all-keys)
2217 (when lambda-list-p
2218 (proclaim (defgeneric-declaration fun-name lambda-list)))))
2220 (defun real-ensure-gf-using-class--null
2221 (existing
2222 fun-name
2223 &rest all-keys
2224 &key environment (lambda-list nil lambda-list-p)
2225 (generic-function-class 'standard-generic-function)
2226 &allow-other-keys)
2227 (declare (ignore existing))
2228 (real-ensure-gf-internal generic-function-class all-keys environment)
2229 (prog1
2230 (setf (gdefinition fun-name)
2231 (apply #'make-instance generic-function-class
2232 :name fun-name all-keys))
2233 (when lambda-list-p
2234 (proclaim (defgeneric-declaration fun-name lambda-list)))))
2236 (defun safe-gf-arg-info (generic-function)
2237 (if (eq (class-of generic-function) *the-class-standard-generic-function*)
2238 (clos-slots-ref (fsc-instance-slots generic-function)
2239 *sgf-arg-info-index*)
2240 (gf-arg-info generic-function)))
2242 ;;; FIXME: this function took on a slightly greater role than it
2243 ;;; previously had around 2005-11-02, when CSR fixed the bug whereby
2244 ;;; having more than one subclass of standard-generic-function caused
2245 ;;; the whole system to die horribly through a metacircle in
2246 ;;; GF-ARG-INFO. The fix is to be slightly more disciplined about
2247 ;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when
2248 ;;; computing discriminating functions, so we need to be careful about
2249 ;;; having a base case for the recursion, and we provide that with the
2250 ;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet)
2251 ;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to
2252 ;;; that stage, where all potentially dangerous cases are enumerated
2253 ;;; and stopped. -- CSR, 2005-11-02.
2254 (defun get-generic-fun-info (gf)
2255 ;; values nreq applyp metatypes nkeys arg-info
2256 (multiple-value-bind (applyp metatypes arg-info)
2257 (let* ((arg-info (if (early-gf-p gf)
2258 (early-gf-arg-info gf)
2259 (safe-gf-arg-info gf)))
2260 (metatypes (arg-info-metatypes arg-info)))
2261 (values (arg-info-applyp arg-info)
2262 metatypes
2263 arg-info))
2264 (values (length metatypes) applyp metatypes
2265 (count-if (lambda (x) (neq x t)) metatypes)
2266 arg-info)))
2268 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
2269 &key slot-name object-class method-class-function)
2270 (let ((parsed ())
2271 (unparsed ()))
2272 ;; Figure out whether we got class objects or class names as the
2273 ;; specializers and set parsed and unparsed appropriately. If we
2274 ;; got class objects, then we can compute unparsed, but if we got
2275 ;; class names we don't try to compute parsed.
2277 ;; Note that the use of not symbolp in this call to every should be
2278 ;; read as 'classp' we can't use classp itself because it doesn't
2279 ;; exist yet.
2280 (if (every (lambda (s) (not (symbolp s))) specializers)
2281 (setq parsed specializers
2282 unparsed (mapcar (lambda (s)
2283 (if (eq s t) t (class-name s)))
2284 specializers))
2285 (setq unparsed specializers
2286 parsed ()))
2287 (let ((result
2288 (list :early-method
2290 (getf initargs :function)
2291 (let ((mf (getf initargs :function)))
2292 (aver mf)
2293 (and (typep mf '%method-function)
2294 (%method-function-fast-function mf)))
2296 ;; the parsed specializers. This is used by
2297 ;; EARLY-METHOD-SPECIALIZERS to cache the parse.
2298 ;; Note that this only comes into play when there is
2299 ;; more than one early method on an early gf.
2300 parsed
2302 ;; A list to which REAL-MAKE-A-METHOD can be applied
2303 ;; to make a real method corresponding to this early
2304 ;; one.
2305 (append
2306 (list class qualifiers arglist unparsed
2307 initargs doc)
2308 (when slot-name
2309 (list :slot-name slot-name :object-class object-class
2310 :method-class-function method-class-function))))))
2311 (initialize-method-function initargs result)
2312 result)))
2314 (defun real-make-a-method
2315 (class qualifiers lambda-list specializers initargs doc
2316 &rest args &key slot-name object-class method-class-function)
2317 (if method-class-function
2318 (let* ((object-class (if (classp object-class) object-class
2319 (find-class object-class)))
2320 (slots (class-direct-slots object-class))
2321 (slot-definition (find slot-name slots
2322 :key #'slot-definition-name)))
2323 (aver slot-name)
2324 (aver slot-definition)
2325 (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list
2326 :specializers specializers :documentation doc
2327 :slot-definition slot-definition
2328 :slot-name slot-name initargs)))
2329 (apply #'make-instance
2330 (apply method-class-function object-class slot-definition
2331 initargs)
2332 initargs)))
2333 (apply #'make-instance class :qualifiers qualifiers
2334 :lambda-list lambda-list :specializers specializers
2335 :documentation doc (append args initargs))))
2337 (defun early-method-function (early-method)
2338 (values (cadr early-method) (caddr early-method)))
2340 (defun early-method-class (early-method)
2341 (find-class (car (fifth early-method))))
2343 (defun early-method-standard-accessor-p (early-method)
2344 (let ((class (first (fifth early-method))))
2345 (or (eq class 'standard-reader-method)
2346 (eq class 'standard-writer-method)
2347 (eq class 'standard-boundp-method))))
2349 (defun early-method-standard-accessor-slot-name (early-method)
2350 (eighth (fifth early-method)))
2352 ;;; Fetch the specializers of an early method. This is basically just
2353 ;;; a simple accessor except that when the second argument is t, this
2354 ;;; converts the specializers from symbols into class objects. The
2355 ;;; class objects are cached in the early method, this makes
2356 ;;; bootstrapping faster because the class objects only have to be
2357 ;;; computed once.
2359 ;;; NOTE:
2360 ;;; The second argument should only be passed as T by
2361 ;;; early-lookup-method. This is to implement the rule that only when
2362 ;;; there is more than one early method on a generic function is the
2363 ;;; conversion from class names to class objects done. This
2364 ;;; corresponds to the fact that we are only allowed to have one
2365 ;;; method on any generic function up until the time classes exist.
2366 (defun early-method-specializers (early-method &optional objectsp)
2367 (if (and (listp early-method)
2368 (eq (car early-method) :early-method))
2369 (cond ((eq objectsp t)
2370 (or (fourth early-method)
2371 (setf (fourth early-method)
2372 (mapcar #'find-class (cadddr (fifth early-method))))))
2374 (fourth (fifth early-method))))
2375 (error "~S is not an early-method." early-method)))
2377 (defun early-method-qualifiers (early-method)
2378 (second (fifth early-method)))
2380 (defun early-method-lambda-list (early-method)
2381 (third (fifth early-method)))
2383 (defun early-method-initargs (early-method)
2384 (fifth (fifth early-method)))
2386 (defun (setf early-method-initargs) (new-value early-method)
2387 (setf (fifth (fifth early-method)) new-value))
2389 (defun early-add-named-method (generic-function-name qualifiers
2390 specializers arglist &rest initargs)
2391 (let* (;; we don't need to deal with the :generic-function-class
2392 ;; argument here because the default,
2393 ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
2394 ;; functions. (See REAL-ADD-NAMED-METHOD)
2395 (gf (ensure-generic-function generic-function-name))
2396 (existing
2397 (dolist (m (early-gf-methods gf))
2398 (when (and (equal (early-method-specializers m) specializers)
2399 (equal (early-method-qualifiers m) qualifiers))
2400 (return m)))))
2401 (setf (getf (getf initargs 'plist) :name)
2402 (make-method-spec gf qualifiers specializers))
2403 (let ((new (make-a-method 'standard-method qualifiers arglist
2404 specializers initargs (getf initargs :documentation))))
2405 (when existing (remove-method gf existing))
2406 (add-method gf new))))
2408 ;;; This is the early version of ADD-METHOD. Later this will become a
2409 ;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has
2410 ;;; special knowledge about ADD-METHOD.
2411 (defun add-method (generic-function method)
2412 (when (not (fsc-instance-p generic-function))
2413 (error "Early ADD-METHOD didn't get a funcallable instance."))
2414 (when (not (and (listp method) (eq (car method) :early-method)))
2415 (error "Early ADD-METHOD didn't get an early method."))
2416 (push method (early-gf-methods generic-function))
2417 (set-arg-info generic-function :new-method method)
2418 (unless (assoc (!early-gf-name generic-function)
2419 *!generic-function-fixups*
2420 :test #'equal)
2421 (update-dfun generic-function)))
2423 ;;; This is the early version of REMOVE-METHOD. See comments on
2424 ;;; the early version of ADD-METHOD.
2425 (defun remove-method (generic-function method)
2426 (when (not (fsc-instance-p generic-function))
2427 (error "An early remove-method didn't get a funcallable instance."))
2428 (when (not (and (listp method) (eq (car method) :early-method)))
2429 (error "An early remove-method didn't get an early method."))
2430 (setf (early-gf-methods generic-function)
2431 (remove method (early-gf-methods generic-function)))
2432 (set-arg-info generic-function)
2433 (unless (assoc (!early-gf-name generic-function)
2434 *!generic-function-fixups*
2435 :test #'equal)
2436 (update-dfun generic-function)))
2438 ;;; This is the early version of GET-METHOD. See comments on the early
2439 ;;; version of ADD-METHOD.
2440 (defun get-method (generic-function qualifiers specializers
2441 &optional (errorp t))
2442 (if (early-gf-p generic-function)
2443 (or (dolist (m (early-gf-methods generic-function))
2444 (when (and (or (equal (early-method-specializers m nil)
2445 specializers)
2446 (equal (early-method-specializers m t)
2447 specializers))
2448 (equal (early-method-qualifiers m) qualifiers))
2449 (return m)))
2450 (if errorp
2451 (error "can't get early method")
2452 nil))
2453 (real-get-method generic-function qualifiers specializers errorp)))
2455 (defun !fix-early-generic-functions ()
2456 (let ((accessors nil))
2457 ;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
2458 ;; FIX-EARLY-GENERIC-FUNCTIONS.
2459 (dolist (early-gf-spec *!early-generic-functions*)
2460 (when (every #'early-method-standard-accessor-p
2461 (early-gf-methods (gdefinition early-gf-spec)))
2462 (push early-gf-spec accessors)))
2463 (dolist (spec (nconc accessors
2464 '(accessor-method-slot-name
2465 generic-function-methods
2466 method-specializers
2467 specializerp
2468 specializer-type
2469 specializer-class
2470 slot-definition-location
2471 slot-definition-name
2472 class-slots
2473 gf-arg-info
2474 class-precedence-list
2475 slot-boundp-using-class
2476 (setf slot-value-using-class)
2477 slot-value-using-class
2478 structure-class-p
2479 standard-class-p
2480 funcallable-standard-class-p
2481 specializerp)))
2482 (/show spec)
2483 (setq *!early-generic-functions*
2484 (cons spec
2485 (delete spec *!early-generic-functions* :test #'equal))))
2487 (dolist (early-gf-spec *!early-generic-functions*)
2488 (/show early-gf-spec)
2489 (let* ((gf (gdefinition early-gf-spec))
2490 (methods (mapcar (lambda (early-method)
2491 (let ((args (copy-list (fifth
2492 early-method))))
2493 (setf (fourth args)
2494 (early-method-specializers
2495 early-method t))
2496 (apply #'real-make-a-method args)))
2497 (early-gf-methods gf))))
2498 (setf (generic-function-method-class gf) *the-class-standard-method*)
2499 (setf (generic-function-method-combination gf)
2500 *standard-method-combination*)
2501 (set-methods gf methods)))
2503 (dolist (fn *!early-functions*)
2504 (/show fn)
2505 (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
2507 (dolist (fixup *!generic-function-fixups*)
2508 (/show fixup)
2509 (let* ((fspec (car fixup))
2510 (gf (gdefinition fspec))
2511 (methods (mapcar (lambda (method)
2512 (let* ((lambda-list (first method))
2513 (specializers (mapcar #'find-class (second method)))
2514 (method-fn-name (third method))
2515 (fn-name (or method-fn-name fspec))
2516 (fn (fdefinition fn-name))
2517 (initargs
2518 (list :function
2519 (set-fun-name
2520 (lambda (args next-methods)
2521 (declare (ignore
2522 next-methods))
2523 (apply fn args))
2524 `(call ,fn-name)))))
2525 (declare (type function fn))
2526 (make-a-method 'standard-method
2528 lambda-list
2529 specializers
2530 initargs
2531 nil)))
2532 (cdr fixup))))
2533 (setf (generic-function-method-class gf) *the-class-standard-method*)
2534 (setf (generic-function-method-combination gf)
2535 *standard-method-combination*)
2536 (set-methods gf methods))))
2537 (/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
2539 ;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument
2540 ;;; into the 'real' arguments. This is where the syntax of DEFMETHOD
2541 ;;; is really implemented.
2542 (defun parse-defmethod (cdr-of-form)
2543 (declare (list cdr-of-form))
2544 (let ((name (pop cdr-of-form))
2545 (qualifiers ())
2546 (spec-ll ()))
2547 (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
2548 (push (pop cdr-of-form) qualifiers)
2549 (return (setq qualifiers (nreverse qualifiers)))))
2550 (setq spec-ll (pop cdr-of-form))
2551 (values name qualifiers spec-ll cdr-of-form)))
2553 (defun parse-specializers (generic-function specializers)
2554 (declare (list specializers))
2555 (flet ((parse (spec)
2556 (parse-specializer-using-class generic-function spec)))
2557 (mapcar #'parse specializers)))
2559 (defun unparse-specializers (generic-function specializers)
2560 (declare (list specializers))
2561 (flet ((unparse (spec)
2562 (unparse-specializer-using-class generic-function spec)))
2563 (mapcar #'unparse specializers)))
2565 (defun extract-parameters (specialized-lambda-list)
2566 (multiple-value-bind (parameters ignore1 ignore2)
2567 (parse-specialized-lambda-list specialized-lambda-list)
2568 (declare (ignore ignore1 ignore2))
2569 parameters))
2571 (defun extract-lambda-list (specialized-lambda-list)
2572 (multiple-value-bind (ignore1 lambda-list ignore2)
2573 (parse-specialized-lambda-list specialized-lambda-list)
2574 (declare (ignore ignore1 ignore2))
2575 lambda-list))
2577 (defun extract-specializer-names (specialized-lambda-list)
2578 (multiple-value-bind (ignore1 ignore2 specializers)
2579 (parse-specialized-lambda-list specialized-lambda-list)
2580 (declare (ignore ignore1 ignore2))
2581 specializers))
2583 (defun extract-required-parameters (specialized-lambda-list)
2584 (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
2585 (parse-specialized-lambda-list specialized-lambda-list)
2586 (declare (ignore ignore1 ignore2 ignore3))
2587 required-parameters))
2589 (define-condition specialized-lambda-list-error
2590 (reference-condition simple-program-error)
2592 (:default-initargs :references (list '(:ansi-cl :section (3 4 3)))))
2594 (defun parse-specialized-lambda-list
2595 (arglist
2596 &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux))
2597 &aux (specialized-lambda-list-keywords
2598 '(&optional &rest &key &allow-other-keys &aux)))
2599 (let ((arg (car arglist)))
2600 (cond ((null arglist) (values nil nil nil nil))
2601 ((eq arg '&aux)
2602 (values nil arglist nil nil))
2603 ((memq arg lambda-list-keywords)
2604 ;; non-standard lambda-list-keywords are errors.
2605 (unless (memq arg specialized-lambda-list-keywords)
2606 (error 'specialized-lambda-list-error
2607 :format-control "unknown specialized-lambda-list ~
2608 keyword ~S~%"
2609 :format-arguments (list arg)))
2610 ;; no multiple &rest x &rest bla specifying
2611 (when (memq arg supplied-keywords)
2612 (error 'specialized-lambda-list-error
2613 :format-control "multiple occurrence of ~
2614 specialized-lambda-list keyword ~S~%"
2615 :format-arguments (list arg)))
2616 ;; And no placing &key in front of &optional, either.
2617 (unless (memq arg allowed-keywords)
2618 (error 'specialized-lambda-list-error
2619 :format-control "misplaced specialized-lambda-list ~
2620 keyword ~S~%"
2621 :format-arguments (list arg)))
2622 ;; When we are at a lambda-list keyword, the parameters
2623 ;; don't include the lambda-list keyword; the lambda-list
2624 ;; does include the lambda-list keyword; and no
2625 ;; specializers are allowed to follow the lambda-list
2626 ;; keywords (at least for now).
2627 (multiple-value-bind (parameters lambda-list)
2628 (parse-specialized-lambda-list (cdr arglist)
2629 (cons arg supplied-keywords)
2630 (if (eq arg '&key)
2631 (cons '&allow-other-keys
2632 (cdr (member arg allowed-keywords)))
2633 (cdr (member arg allowed-keywords))))
2634 (when (and (eq arg '&rest)
2635 (or (null lambda-list)
2636 (memq (car lambda-list)
2637 specialized-lambda-list-keywords)
2638 (not (or (null (cadr lambda-list))
2639 (memq (cadr lambda-list)
2640 specialized-lambda-list-keywords)))))
2641 (error 'specialized-lambda-list-error
2642 :format-control
2643 "in a specialized-lambda-list, excactly one ~
2644 variable must follow &REST.~%"
2645 :format-arguments nil))
2646 (values parameters
2647 (cons arg lambda-list)
2649 ())))
2650 (supplied-keywords
2651 ;; After a lambda-list keyword there can be no specializers.
2652 (multiple-value-bind (parameters lambda-list)
2653 (parse-specialized-lambda-list (cdr arglist)
2654 supplied-keywords
2655 allowed-keywords)
2656 (values (cons (if (listp arg) (car arg) arg) parameters)
2657 (cons arg lambda-list)
2659 ())))
2661 (multiple-value-bind (parameters lambda-list specializers required)
2662 (parse-specialized-lambda-list (cdr arglist))
2663 (values (cons (if (listp arg) (car arg) arg) parameters)
2664 (cons (if (listp arg) (car arg) arg) lambda-list)
2665 (cons (if (listp arg) (cadr arg) t) specializers)
2666 (cons (if (listp arg) (car arg) arg) required)))))))
2668 (setq *boot-state* 'early)
2670 ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
2671 ;;; which used %WALKER stuff. That suggests to me that maybe the code
2672 ;;; walker stuff was only used for implementing stuff like that; maybe
2673 ;;; it's not needed any more? Hunt down what it was used for and see.
2675 (defun extract-the (form)
2676 (cond ((and (consp form) (eq (car form) 'the))
2677 (aver (proper-list-of-length-p 3))
2678 (third form))
2680 form)))
2682 (defmacro with-slots (slots instance &body body)
2683 (let ((in (gensym)))
2684 `(let ((,in ,instance))
2685 (declare (ignorable ,in))
2686 ,@(let ((instance (extract-the instance)))
2687 (and (symbolp instance)
2688 `((declare (%variable-rebinding ,in ,instance)))))
2690 (symbol-macrolet ,(mapcar (lambda (slot-entry)
2691 (let ((var-name
2692 (if (symbolp slot-entry)
2693 slot-entry
2694 (car slot-entry)))
2695 (slot-name
2696 (if (symbolp slot-entry)
2697 slot-entry
2698 (cadr slot-entry))))
2699 `(,var-name
2700 (slot-value ,in ',slot-name))))
2701 slots)
2702 ,@body))))
2704 (defmacro with-accessors (slots instance &body body)
2705 (let ((in (gensym)))
2706 `(let ((,in ,instance))
2707 (declare (ignorable ,in))
2708 ,@(let ((instance (extract-the instance)))
2709 (and (symbolp instance)
2710 `((declare (%variable-rebinding ,in ,instance)))))
2712 (symbol-macrolet ,(mapcar (lambda (slot-entry)
2713 (let ((var-name (car slot-entry))
2714 (accessor-name (cadr slot-entry)))
2715 `(,var-name (,accessor-name ,in))))
2716 slots)
2717 ,@body))))