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

Contents of /src/pcl/info.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.11: +8 -7 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de>
2 ;;; All rights reserved.
3 ;;;
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
6 ;;; are met:
7 ;;;
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote
14 ;;; products derived from this software without specific prior written
15 ;;; permission.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
21 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
23 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
24 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
26 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
27 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
28 ;;; DAMAGE.
29
30 ;;; The function SPLIT-DECLARATION appeared first in Xerox PCL
31 ;;; vector.lisp, and was moved here for concentrating all declaration
32 ;;; stuff. See vector.lisp for Xerox' copyright and license.
33
34 ;;; To Do
35 ;;;
36 ;;; GF is actually non-accessor GF. Clean this up.
37 ;;; (setf symbol-value) should be handled like (setf fdefinition)
38
39 (file-comment "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/info.lisp,v 1.12 2010/03/19 15:19:03 rtoy Rel $")
40
41 (in-package "PCL")
42 (intl:textdomain "cmucl")
43
44 (defstruct class-info
45 ;;
46 ;; List of SLOT-INFO structures for each slot.
47 (slots () :type list)
48 ;;
49 ;; The class' metaclass.
50 (metaclass nil :type symbol)
51 ;;
52 ;; List of slot reader and writer function names.
53 (accessors () :type list)
54 ;;
55 ;; Slot access optimization info.
56 (slot-access () :type list))
57
58
59 (defstruct slot-info
60 (name nil :type symbol)
61 ;;
62 ;; Specified slot allocation.
63 (allocation :instance :type (or (member :class :instance) t))
64 ;;
65 ;; Specified slot type or T.
66 (type t :type (or symbol list)))
67
68
69 (defstruct gf-info
70 ;;
71 ;; Number of required parameters.
72 (nreq 0 :type fixnum)
73 ;;
74 ;; True if this generic function has key, optional, or rest parameters.
75 (applyp nil :type boolean)
76 ;;
77 ;; READER if this generic function has a slot reader method.
78 ;; WRITER if this gf has a slot writer method.
79 ;; NIL if this is an ordinary generic function.
80 (type nil :type (member nil reader writer))
81 ;;
82 ;; List of class names for slot accessor. A class C occurring in
83 ;; this list means that this is a slot accessor for some slot of C.
84 (classes () :type list)
85 ;;
86 ;; Alist of AUTO-COMPILE declaration infos for methods. Keys are
87 ;; (QUALIFIER* SPECIALIZERS), value is T or NIL for do or don't
88 ;; auto-compile.
89 (auto-compile () :type list)
90 ;;
91 ;; The default auto-compilation policy used for methods of this
92 ;; generic function which don't have explicit entries in
93 ;; AUTO-COMPILE. T means auto-compile, NIL don't auto-compile,
94 ;; MAYBE means use the global default.
95 (auto-compile-default 'maybe :type (member t nil maybe)))
96
97 (defstruct seal-info
98 (seals () :type list))
99
100 ;;;
101 ;;; Declare some new INFO type, under class PCL, plus nicer accessors.
102 ;;;
103 (define-info-class pcl)
104 (define-info-type pcl class (or null class-info) nil)
105 (define-info-type pcl gf (or null gf-info) nil)
106 (define-info-type pcl seal (or null seal-info) nil)
107
108 (declaim (inline class-info (setf class-info)
109 gf-info (setf gf-info)
110 seal-info (setf seal-info)))
111
112 (defun class-info (class-name)
113 (info pcl class class-name))
114
115 (defun (setf class-info) (new-value class-name)
116 (setf (info pcl class class-name) new-value))
117
118 (defun class-info-or-make (class-name)
119 (let ((info (class-info class-name)))
120 (or info
121 (setf (class-info class-name) (make-class-info)))))
122
123 (defun gf-info (gf-name)
124 (info pcl gf gf-name))
125
126 (defun (setf gf-info) (new-value gf-name)
127 (setf (info pcl gf gf-name) new-value))
128
129 (defun gf-info-or-make (gf-name)
130 (let ((info (gf-info gf-name)))
131 (or info
132 (setf (gf-info gf-name) (make-gf-info)))))
133
134 (defun seal-info (name)
135 (info pcl seal name))
136
137 (defun (setf seal-info) (new-value name)
138 (setf (info pcl seal name) new-value))
139
140 (defun seal-info-or-make (name)
141 (let ((info (seal-info name)))
142 (or info
143 (setf (seal-info name) (make-seal-info)))))
144
145
146 ;;; ******************
147 ;;; Classes ********
148 ;;; ******************
149
150 ;;;
151 ;;; Set compile-time info for class CLASS-NAME. Called from
152 ;;; EXPAND-DEFCLASS.
153 ;;;
154 ;;; METACLASS is the metaclass of the declared class. SLOTS is a
155 ;;; list of slot specs as they appear in DEFCLASS.
156 ;;;
157 (defun set-class-info (class-name metaclass slots)
158 (let ((readers ())
159 (writers ())
160 (slot-infos ())
161 (class-info (class-info class-name)))
162 (when class-info
163 (loop for a in (class-info-accessors class-info)
164 as info = (gf-info a)
165 when info do
166 ;; INFO can be NIL when the accessor has been redefined
167 ;; as an ordinary function.
168 (setf (gf-info-classes info)
169 (delete class-name (gf-info-classes info)))))
170 ;;
171 (dolist (slot slots)
172 (typecase slot
173 (list
174 (loop for (key value) on (cdr slot) by #'cddr do
175 (case key
176 (:reader
177 (push value readers))
178 (:writer
179 (push value writers))
180 (:accessor
181 (push value readers)
182 (push `(setf ,value) writers))))
183 (push (make-slot-info
184 :name (car slot)
185 :allocation (getf (cdr slot) :allocation :instance)
186 :type (getf (cdr slot) :type t))
187 slot-infos))
188 (t
189 (push (make-slot-info :name slot) slot-infos))))
190 ;;
191 (setf (class-info class-name)
192 (make-class-info
193 :slots (nreverse slot-infos)
194 :accessors (append readers writers)
195 :metaclass metaclass
196 :slot-access (and class-info
197 (class-info-slot-access class-info))))
198 ;;
199 (flet ((add-class (accessors type)
200 (loop for a in accessors as info = (gf-info a)
201 if (null info) do
202 (setf (gf-info a)
203 (make-gf-info :nreq (ecase type
204 (reader 1)
205 (writer 2))
206 :applyp nil
207 :classes (list class-name)
208 :type type))
209 else do
210 (setf (gf-info-type info) type)
211 (push class-name (gf-info-classes info)))))
212 (add-class readers 'reader)
213 (add-class writers 'writer))))
214
215 ;;;
216 ;;; Decide what type slot SLOT-NAME in CLASS-OR-NAME has.
217 ;;; CLASS-OR-NAME can be a class or class name.
218 ;;;
219 (defun decide-slot-type (class-or-name slot-name)
220 (or (let* ((class-info (class-info (if (symbolp class-or-name)
221 class-or-name
222 (class-name class-or-name))))
223 (slot-info (when class-info
224 (find slot-name (class-info-slots class-info)
225 :key #'slot-info-name :test #'eq))))
226 (when slot-info
227 (slot-info-type slot-info)))
228 (let* ((class (if (symbolp class-or-name)
229 (find-class class-or-name nil)
230 class-or-name))
231 (slotd (when (if (eq *boot-state* 'complete)
232 (std-class-p class)
233 class)
234 (find-slot-definition class slot-name))))
235 (when slotd
236 (slot-definition-type slotd)))))
237
238 ;;;
239 ;;; Test if a class names a STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS.
240 ;;;
241 (macrolet ((defpred (name metaclass)
242 `(defun ,name (class-name)
243 (let ((class (find-class class-name nil)))
244 (if class
245 (typep class ',metaclass)
246 (let* ((info (class-info class-name))
247 (meta (and info (class-info-metaclass info))))
248 (eq meta ',metaclass)))))))
249 (defpred info-funcallable-standard-class-p funcallable-standard-class)
250 (defpred info-standard-class-p standard-class))
251
252
253 ;;; **************
254 ;;; Slots *******
255 ;;; **************
256
257 ;;;
258 ;;; Return true if NAME should be considerd a slot reader/writer name.
259 ;;;
260 (defun info-accessor-p (name)
261 (or (let ((info (gf-info name)))
262 (when info
263 (not (null (gf-info-type info)))))
264 (when (and (eq *boot-state* 'complete)
265 (fboundp name))
266 (let ((gf (gdefinition name))
267 (accessorp nil))
268 (when (generic-function-p gf)
269 (loop for method in (generic-function-methods gf)
270 when (standard-accessor-method-p method) do
271 (setq accessorp t)
272 (let ((type (if (standard-reader-method-p method)
273 'reader 'writer)))
274 (setf (gf-info name)
275 (make-gf-info :nreq (ecase type
276 (reader 1)
277 (writer 2))
278 :applyp nil
279 :type type
280 :classes ())))
281 (loop-finish)))
282 accessorp))))
283
284 ;;;
285 ;;; Decide if a call to GF-NAME should be optimized as a slot
286 ;;; reader/writer call of type TYPE. TYPE must be one of the symbols
287 ;;; READER or WRITER.
288 ;;;
289 (defun decide-optimize-accessor-p (gf-name type)
290 (let ((info (gf-info gf-name)))
291 (when info
292 (eq type (gf-info-type info)))))
293
294 ;;;
295 ;;; Decide if access to slot SLOT-NAME in class CLASS-NAME should be
296 ;;; optimized. TYPE is the type of access, one of READER/WRITER/ALL.
297 ;;;
298 ;;; This function is called from COMPUTE-PV-SLOT and from the code
299 ;;; actually generating the code for optimized slot access. It's
300 ;;; suboptimal but okay if this function errs: either we'll be doing a
301 ;;; superfluous optimization or prevent a possible optimization. The
302 ;;; PV code must anyway be able to cope with optimizations that must
303 ;;; be "undone" by setting pv-values to nil.
304 ;;;
305 ;;; It's worthwhile optimizing slot access if we know or suspect at
306 ;;; method compilation time that slots are accessed in the standard
307 ;;; way, which means that there is no non-standard
308 ;;; SLOT-VALUE-USING-CLASS method defined.
309 ;;;
310 ;;; If we know that there is or will be such a method, it's not worth
311 ;;; optimizing.
312 ;;;
313 (defun decide-optimize-slot-p (class-name slot-name type)
314 (or (let ((class-info (class-info class-name)))
315 (and class-info
316 (member slot-name (class-info-slots class-info)
317 :key #'slot-info-name :test #'eq)
318 ;; FUNCALLABLE-STANDARD-CLASS might be ok, too, I haven't
319 ;; checked. It's not terribly important, though.
320 (eq (class-info-metaclass class-info) 'standard-class)))
321 (let* ((class (find-class class-name nil))
322 (slotd (and class (find-slot-definition class slot-name))))
323 (when slotd
324 (slot-accessor-std-p slotd type)))))
325
326 ;;;
327 ;;; Decide if SLOT-NAME should be considered a class slot in class
328 ;;; CLASS-NAME.
329 ;;;
330 (defun decide-class-slot-p (class-name slot-name)
331 (or (let* ((class-info (class-info class-name))
332 (slot-info (and class-info
333 (find slot-name (class-info-slots class-info)
334 :key #'slot-info-name :test #'eq))))
335 (when slot-info
336 (eq :class (slot-info-allocation slot-info))))
337 (let* ((class (find-class class-name nil))
338 (slotd (and class (find-slot-definition class slot-name))))
339 (when slotd
340 (eq :class (slot-definition-allocation slotd))))))
341
342
343 ;;; ***************************
344 ;;; Generic Functions *******
345 ;;; ***************************
346
347 ;;;
348 ;;; Record compile-time information about the declaration of
349 ;;; generic function GF-NAME with lambda list LAMBDA-LIST.
350 ;;;
351 (defun set-gf-info (gf-name lambda-list)
352 (multiple-value-bind (required optional restp rest keyp keys
353 allow-other-keys-p)
354 (parse-generic-function-lambda-list lambda-list)
355 (declare (ignore rest keys))
356 (setf (gf-info gf-name)
357 (make-gf-info :nreq (length required)
358 ;; Like in ARG-INFO-APPLYP.
359 :applyp (or restp keyp (not (null optional))
360 allow-other-keys-p)))))
361
362 ;;;
363 ;;; Return true if NAME is the name of a known generic function.
364 ;;;
365 (defun info-gf-name-p (name)
366 (when (valid-function-name-p name)
367 (or (gf-info name)
368 (when (and (fboundp name)
369 (eq *boot-state* 'complete))
370 (let ((gf (gdefinition name)))
371 (when (standard-generic-function-p gf)
372 (set-gf-info name (generic-function-lambda-list gf))
373 t))))))
374
375 ;;;
376 ;;; Called to update the info database and pv caches when function
377 ;;; NAME gets redefined to NEWDEF. If NAME is a generic function,
378 ;;; flush pv caches referring to it.
379 ;;;
380 (defun %check-gf-redefinition (name newdef)
381 (when (eq *boot-state* 'complete)
382 (let ((gf (and (fboundp name)
383 (not (memq (car-safe name)
384 '(effective-method method fast-method
385 slot-accessor)))
386 (gdefinition name))))
387 (when (and gf
388 (generic-function-p gf)
389 (not (generic-function-p newdef)))
390 (setf (gf-info name) nil)
391 (update-accessor-pvs 'removed-gf gf)
392 (update-pv-calls-for-gf gf 'removed-gf)))))
393
394 (push #'%check-gf-redefinition lisp::*setf-fdefinition-hook*)
395
396
397 ;;; **********************
398 ;;; Declarations ********
399 ;;; **********************
400
401 (defvar *non-variable-declarations*
402 '(ftype
403 inline
404 method-lambda-list
405 method-name
406 notinline
407 optimize
408 values))
409
410 (defvar *variable-declarations-with-argument*
411 '(class
412 type))
413
414 (defvar *variable-declarations-without-argument*
415 '(array
416 atom
417 base-char
418 bignum
419 bit
420 bit-vector
421 character
422 compiled-function
423 complex
424 cons
425 double-float
426 dynamic-extent
427 extended-char
428 fixnum
429 float function
430 hash-table
431 ignorable
432 ignore
433 integer
434 keyword
435 list
436 long-float
437 nil
438 null
439 number
440 package
441 pathname
442 random-state
443 ratio
444 rational
445 readtable
446 sequence
447 short-float
448 signed-byte
449 simple-array
450 simple-bit-vector
451 simple-string
452 simple-vector
453 single-float
454 special
455 standard-char
456 stream
457 string
458 symbol
459 t
460 unsigned-byte
461 vector))
462
463 (defvar *slots-qualities*
464 '(inline
465 slot-boundp))
466
467 (defun split-declarations (body args calls-next-method-p)
468 (declare (ignore calls-next-method-p))
469 (let ((inner-decls nil) (outer-decls nil) decl)
470 (loop (when (null body) (return nil))
471 (setq decl (car body))
472 (unless (and (consp decl)
473 (eq (car decl) 'declare))
474 (return nil))
475 (dolist (form (cdr decl))
476 (when (consp form)
477 (let ((declaration-name (car form)))
478 (if (member declaration-name *non-variable-declarations*)
479 (push `(declare ,form) outer-decls)
480 (let ((arg-p
481 (member declaration-name
482 *variable-declarations-with-argument*))
483 (non-arg-p
484 (member declaration-name
485 *variable-declarations-without-argument*))
486 (dname (list (pop form))))
487 (unless (or arg-p non-arg-p)
488 (warn _"~@<The declaration ~S is not understood by ~S. ~
489 Please put ~S on one of the lists ~S, ~S, or ~S. ~
490 (Assuming it is a variable declarations without ~
491 argument).~@:>"
492 declaration-name 'split-declarations
493 declaration-name
494 '*non-variable-declarations*
495 '*variable-declarations-with-argument*
496 '*variable-declarations-without-argument*)
497 (push declaration-name
498 *variable-declarations-without-argument*))
499 (when arg-p
500 (setq dname (append dname (list (pop form)))))
501 ;;
502 ;; The PCL-internal declaration CLASS has the
503 ;; form (DECLARE (CLASS <parameter> <class>),
504 ;; which is incompatible with what the DOLIST
505 ;; below does.
506 (case (car dname)
507 (class
508 (push `(declare (,@dname ,@form)) inner-decls))
509 (t
510 (let ((inners nil) (outers nil))
511 (dolist (var form)
512 (if (member var args)
513 ;; Quietly remove ignore declarations
514 ;; on args to prevent compiler warns
515 ;; about ignored args being read in
516 ;; CALL-NEXT-METHOD.
517 (unless (eq (car dname) 'ignore)
518 (push var outers))
519 (push var inners)))
520 (when outers
521 (push `(declare (,@dname ,@outers)) outer-decls))
522 (when inners
523 (push `(declare (,@dname ,@inners)) inner-decls))))))))))
524 (setq body (cdr body)))
525 (values outer-decls inner-decls body)))
526
527
528 ;;;; ********************************
529 ;;;; Adding New Declarations *******
530 ;;;; ********************************
531
532 (eval-when (compile load eval)
533 (defvar *declaration-handlers* ())
534
535 (defun %define-declaration (decl-name handler-name)
536 (let ((entry (assoc decl-name *declaration-handlers*)))
537 (if entry
538 (setf (cdr entry) handler-name)
539 (setq *declaration-handlers*
540 (acons decl-name handler-name *declaration-handlers*))))))
541
542 (defmacro define-declaration (decl-name lambda-list &body body)
543 (let ((handler-name (symbolicate 'handle- decl-name '-declaration)))
544 `(eval-when (compile load eval)
545 (declaim (declaration ,decl-name))
546 (defun ,handler-name ,lambda-list ,@body)
547 (%define-declaration ',decl-name ',handler-name))))
548
549 (defun proclamation-hook (form)
550 (when (consp form)
551 (let ((handler (cdr (assoc (car form) *declaration-handlers*))))
552 (when handler
553 (funcall handler form)))))
554
555 (pushnew 'proclamation-hook c::*proclamation-hooks*)
556
557
558 ;;;; ***************************
559 ;;;; SLOTS declaration ********
560 ;;;; ***************************
561
562 (pushnew 'slots *variable-declarations-with-argument*)
563 (pushnew 'slots walker:*variable-declarations*)
564
565 (define-declaration slots (form)
566 (flet ((invalid (&optional subform)
567 (if subform
568 (warn _"~@<Invalid slot access specifier ~s in ~s.~@:>"
569 subform form)
570 (warn _"~@<Invalid slot access declaration ~s.~@:>"
571 form))))
572 (dolist (specifier (cdr form))
573 (if (and (consp specifier)
574 (memq (car specifier) *slots-qualities*))
575 (dolist (class-entry (cdr specifier))
576 (let (class slots)
577 (typecase class-entry
578 (symbol
579 (setq class class-entry))
580 (cons
581 (setq class (car class-entry))
582 (setq slots (cdr class-entry)))
583 (t
584 (invalid specifier)))
585 (when class
586 (let* ((info (class-info-or-make class))
587 (entry (assoc (car specifier)
588 (class-info-slot-access info))))
589 (if entry
590 (setf (cdr entry) slots)
591 (push (list* (car specifier) slots)
592 (class-info-slot-access info)))))))
593 (invalid)))))
594
595 ;;;
596 ;;; True if there is a slot optimization declaration DECLARATION in
597 ;;; ENV for CLASS and SLOT-NAME. Slot optimization declarations look
598 ;;; like
599 ;;;
600 ;;; declare (pcl:slots specifier*)
601 ;;;
602 ;;; specifier ::= (quality class-entry*)
603 ;;; quality ::= SLOT-BOUNDP | INLINE
604 ;;; class-entry ::= class | (class slot-name*)
605 ;;; class ::= the name of a class
606 ;;; slot-name ::= the name of a slot
607 ;;;
608 ;;; Examples:
609 ;;;
610 ;;; (declare (slots (slot-boundp my-class)))
611 ;;; (declare (slots (inline (my-class slot-a))))
612 ;;;
613 (defun slot-declaration (env quality class &optional slot-name)
614 (assert (memq quality *slots-qualities*))
615 (or (when env
616 (local-slot-declaration env quality class slot-name))
617 (global-slot-declaration quality class slot-name)))
618
619 (defun local-slot-declaration (env quality class &optional slot-name)
620 (let ((class-name (if (symbolp class) class (class-name class))))
621 (dolist (decl (walker::env-declarations env))
622 (when (and (consp decl)
623 (eq (car decl) 'slots)
624 (slot-access-specifier (cdr decl) quality class-name
625 slot-name))
626 (return t)))))
627
628 (defun slot-access-specifier (specifiers quality class-name
629 &optional slot-name)
630 (dolist (specifier specifiers)
631 (when (and (consp specifier) (eq quality (car specifier)))
632 (dolist (entry (cdr specifier))
633 (when (typecase entry
634 (symbol
635 (eq entry class-name))
636 (cons
637 (and (eq (car entry) class-name)
638 (or (null slot-name)
639 (null (cdr entry))
640 (memq slot-name (cdr entry)))))
641 (t (warn _"~@<Invalid slot access declaration ~s.~@:>"
642 specifier)))
643 (return-from slot-access-specifier entry))))))
644
645 (defun global-slot-declaration (quality class &optional slot-name)
646 (let* ((info (class-info (if (symbolp class) class (class-name class))))
647 (spec (when info (assq quality (class-info-slot-access info)))))
648 (and spec
649 (or (null slot-name)
650 (null (cdr spec))
651 (memq slot-name (cdr spec))))))
652
653 (defun class-has-a-forward-referenced-superclass-p (class)
654 (or (forward-referenced-class-p class)
655 (some #'class-has-a-forward-referenced-superclass-p
656 (class-direct-superclasses class))))
657
658 ;;;
659 ;;; Return true if class CLASS-NAME should be defined at compile time.
660 ;;; Called from EXPAND-DEFCLASS. ENV is the environment in which the
661 ;;; DEFCLASS of CLASS-NAME appears. SUPERS is the list of superclass
662 ;;; names for CLASS-NAME.
663 ;;;
664 (defun define-class-at-compile-time-p (env class-name &optional supers)
665 (or (slot-declaration env 'inline class-name)
666 (some (lambda (super)
667 (let ((class (find-class super nil)))
668 (and class
669 (not (class-has-a-forward-referenced-superclass-p class))
670 (some (lambda (c)
671 (slot-declaration env 'inline c))
672 (class-precedence-list class)))))
673 supers)))
674
675
676 ;;;; *********************************
677 ;;;; AUTO-COMPILE declaration *******
678 ;;;; *********************************
679
680 (define-declaration auto-compile (form)
681 (auto-compile-proclamation form t))
682
683 (define-declaration not-auto-compile (form)
684 (auto-compile-proclamation form nil))
685
686 (defvar *auto-compile-global-default* nil)
687
688 (defun auto-compile-proclamation (form compilep)
689 (flet ((invalid (&optional subform)
690 (if subform
691 (warn _"~@<Invalid auto-compile specifier ~s in ~s.~@:>"
692 subform form)
693 (warn _"~@<Invalid auto-compile declaration ~s.~@:>"
694 form)))
695 (gf-name-p (name)
696 (valid-function-name-p name)))
697 (if (null (cdr form))
698 (setq *auto-compile-global-default* compilep)
699 (dolist (specifier (cdr form))
700 (cond ((or (gf-name-p specifier)
701 (and (consp specifier)
702 (gf-name-p (car specifier))
703 (null (cdr specifier))))
704 (let ((info (gf-info-or-make (if (gf-name-p specifier)
705 specifier
706 (car specifier)))))
707 (setf (gf-info-auto-compile-default info) compilep)))
708 ((and (consp specifier)
709 (gf-name-p (car specifier)))
710 (let* ((info (gf-info-or-make (car specifier)))
711 (entry (assoc (cdr specifier)
712 (gf-info-auto-compile info)
713 :test #'equal)))
714 (if entry
715 (setf (cdr entry) compilep)
716 (setf (gf-info-auto-compile info)
717 (acons (cdr specifier) compilep
718 (gf-info-auto-compile info))))))
719 (t
720 (invalid specifier)))))))
721
722 ;;;
723 ;;; Return true if method with the given name, qualifiers, and
724 ;;; specializers should be auto-compiled.
725 ;;;
726 (defun auto-compile-p (gf-name qualifiers specializers)
727 (when (eq *boot-state* 'complete)
728 (let* ((info (gf-info gf-name))
729 (key (append qualifiers (list specializers)))
730 (compilep (if info
731 (let ((entry (assoc key (gf-info-auto-compile info)
732 :test #'equal)))
733 (if entry
734 (cdr entry)
735 (gf-info-auto-compile-default info)))
736 'maybe)))
737 (if (eq 'maybe compilep)
738 *auto-compile-global-default*
739 compilep))))
740
741 ;;; end of info.lisp

  ViewVC Help
Powered by ViewVC 1.1.5