1 ;;;; This software is part of the SBCL system. See the README file for
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
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
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
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
26 ;;; (These are left over from the days when PCL was an add-on package
27 ;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
28 ;;; build, of course, but they might happen if someone is experimenting
29 ;;; and debugging, and it's probably worth complaining if they do,
30 ;;; so we've left 'em in.)
31 (when (eq **boot-state
** 'complete
)
32 (error "Trying to load (or compile) PCL in an environment in which it~%~
33 has already been loaded. This doesn't work, you will have to~%~
34 get a fresh lisp (reboot) and then load PCL."))
36 (cerror "Try loading (or compiling) PCL anyways."
37 "Trying to load (or compile) PCL in an environment in which it~%~
38 has already been partially loaded. This may not work, you may~%~
39 need to get a fresh lisp (reboot) and then load PCL."))
41 #-sb-fluid
(declaim (inline gdefinition
))
42 (defun gdefinition (spec)
43 ;; This is null layer right now, but once FDEFINITION stops bypasssing
44 ;; fwrappers/encapsulations we can do that here.
47 (defun (setf gdefinition
) (new-value spec
)
48 ;; This is almost a null layer right now, but once (SETF
49 ;; FDEFINITION) stops bypasssing fwrappers/encapsulations we can do
51 (sb-c::note-name-defined spec
:function
) ; FIXME: do we need this? Why?
52 (setf (fdefinition spec
) new-value
))
54 ;;;; type specifier hackery
56 ;;; internal to this file
57 (defun coerce-to-class (class &optional make-forward-referenced-class-p
)
59 (or (find-class class
(not make-forward-referenced-class-p
))
64 (defun specializer-from-type (type &aux args
)
65 ;; Avoid style-warning about compiler-macro being unavailable.
66 (declare (notinline make-instance
))
68 (return-from specializer-from-type
(find-class type
)))
70 (setq args
(cdr type
) type
(car type
)))
73 (class (coerce-to-class (car args
)))
74 (prototype (make-instance 'class-prototype-specializer
75 :object
(coerce-to-class (car args
))))
76 (class-eq (class-eq-specializer (coerce-to-class (car args
))))
77 (eql (intern-eql-specializer (car args
))))))
78 ;; FIXME: do we still need this?
79 ((and (null args
) (typep type
'classoid
))
80 (or (classoid-pcl-class type
)
81 (ensure-non-standard-class (classoid-name type
) type
)))
82 ((specializerp type
) type
)))
85 (defun type-from-specializer (specl)
89 (unless (member (car specl
) '(class prototype class-eq eql
))
90 (error "~S is not a legal specializer type." specl
))
94 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
95 (setq specl
(find-class specl
)))
96 (or (not (eq **boot-state
** 'complete
))
97 (specializerp specl
)))
98 (specializer-type specl
))
100 (error "~S is neither a type nor a specializer." specl
))))
102 (defun type-class (type)
103 (declare (special *the-class-t
*))
104 (setq type
(type-from-specializer type
))
108 (error "bad argument to TYPE-CLASS"))
110 (eql (class-of (cadr type
)))
111 (prototype (class-of (cadr type
))) ;?
112 (class-eq (cadr type
))
113 (class (cadr type
)))))
115 (defun class-eq-type (class)
116 (specializer-type (class-eq-specializer class
)))
118 ;;; internal to this file..
120 ;;; These functions are a pale imitation of their namesake. They accept
121 ;;; class objects or types where they should.
122 (defun *normalize-type
(type)
124 (if (member (car type
) '(not and or
))
125 `(,(car type
) ,@(mapcar #'*normalize-type
(cdr type
)))
126 (if (null (cdr type
))
127 (*normalize-type
(car type
))
130 (let ((class (find-class type nil
)))
132 (let ((type (specializer-type class
)))
135 ((or (not (eq **boot-state
** 'complete
))
137 (specializer-type type
))
139 (error "~S is not a type." type
))))
141 ;;; internal to this file...
142 (defun convert-to-system-type (type)
144 ((not and or
) `(,(car type
) ,@(mapcar #'convert-to-system-type
146 ((class class-eq
) ; class-eq is impossible to do right
147 (layout-classoid (class-wrapper (cadr type
))))
149 (t (if (null (cdr type
))
153 ;;; Writing the missing NOT and AND clauses will improve the quality
154 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
155 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
156 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
158 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
159 ;;; in the compiler. Could we share some of it here?
160 (defvar *in-
*subtypep
* nil
)
162 (defun *subtypep
(type1 type2
)
163 (if (equal type1 type2
)
165 (if (eq **boot-state
** 'early
)
166 (values (eq type1 type2
) t
)
167 (let ((*in-
*subtypep
* t
))
168 (setq type1
(*normalize-type type1
))
169 (setq type2
(*normalize-type type2
))
172 (values nil nil
)) ; XXX We should improve this.
174 (values nil nil
)) ; XXX We should improve this.
175 ((eql wrapper-eq class-eq class
)
176 (multiple-value-bind (app-p maybe-app-p
)
177 (specializer-applicable-using-type-p type2 type1
)
178 (values app-p
(or app-p
(not maybe-app-p
)))))
180 (subtypep (convert-to-system-type type1
)
181 (convert-to-system-type type2
))))))))
183 (defvar *built-in-class-symbols
* ())
184 (defvar *built-in-wrapper-symbols
* ())
186 (defun get-built-in-class-symbol (class-name)
187 (or (cadr (assq class-name
*built-in-class-symbols
*))
188 (let ((symbol (make-class-symbol class-name
)))
189 (push (list class-name symbol
) *built-in-class-symbols
*)
192 (defvar *standard-method-combination
*)
193 (defvar *or-method-combination
*)
195 (defun plist-value (object name
)
196 (getf (object-plist object
) name
))
198 (defun (setf plist-value
) (new-value object name
)
200 (setf (getf (object-plist object
) name
) new-value
)
202 (remf (object-plist object
) name
)
205 ;;;; built-in classes
207 ;;; Grovel over SB-KERNEL::*!BUILT-IN-CLASSES* in order to set
208 ;;; SB-PCL:*BUILT-IN-CLASSES*.
209 (/show
"about to set up SB-PCL::*BUILT-IN-CLASSES*")
210 (defvar *built-in-classes
*
211 (labels ((direct-supers (class)
212 (/noshow
"entering DIRECT-SUPERS" (classoid-name class
))
213 (if (typep class
'built-in-classoid
)
214 (built-in-classoid-direct-superclasses class
)
215 (let ((inherits (layout-inherits
216 (classoid-layout class
))))
218 (list (svref inherits
(1- (length inherits
)))))))
220 (/noshow
"entering DIRECT-SUBS" (classoid-name class
))
222 (let ((subs (classoid-subclasses class
)))
225 (dohash ((sub v
) subs
)
228 (when (member class
(direct-supers sub
) :test
#'eq
)
231 (mapcar (lambda (kernel-bic-entry)
232 (/noshow
"setting up" kernel-bic-entry
)
233 (let* ((name (car kernel-bic-entry
))
234 (class (find-classoid name
))
236 (getf (cdr kernel-bic-entry
) :prototype-form
)))
239 ,(mapcar #'classoid-name
(direct-supers class
))
240 ,(mapcar #'classoid-name
(direct-subs class
))
244 (layout-classoid x
)))
247 (classoid-layout class
))))
249 (eval prototype-form
)
250 ;; This is the default prototype value which
251 ;; was used, without explanation, by the CMU CL
252 ;; code we're derived from. Evidently it's safe
253 ;; in all relevant cases.
255 (remove-if (lambda (kernel-bic-entry)
256 (member (first kernel-bic-entry
)
257 ;; remove special classes (T and our
258 ;; SYSTEM-CLASSes) from the
259 ;; BUILT-IN-CLASS list
260 '(t function stream sequence
261 file-stream string-stream
)))
262 sb-kernel
::*!built-in-classes
*))))
263 (/noshow
"done setting up SB-PCL::*BUILT-IN-CLASSES*")
265 ;;;; the classes that define the kernel of the metabraid
268 ;; AMOP specifies that the class named T should be an instance of
269 ;; BUILT-IN-CLASS, but this conflicts with other specifications in
271 (:metaclass system-class
))
273 (defclass function
(t) ()
274 (:metaclass system-class
))
276 (defclass stream
(t) ()
277 (:metaclass system-class
))
279 (defclass file-stream
(stream) ()
280 (:metaclass system-class
))
282 (defclass string-stream
(stream) ()
283 (:metaclass system-class
))
285 (defclass sequence
(t) ()
286 (:metaclass system-class
))
288 (defclass slot-object
(t) ()
289 (:metaclass slot-class
))
291 (defclass condition
(slot-object) ()
292 (:metaclass condition-class
))
294 (defclass structure-object
(slot-object) ()
295 (:metaclass structure-class
))
297 (defstruct (dead-beef-structure-object
298 (:constructor |STRUCTURE-OBJECT class constructor|
)
301 (defclass standard-object
(slot-object) ())
303 (defclass funcallable-standard-object
(function standard-object
)
305 (:metaclass funcallable-standard-class
))
307 (defclass metaobject
(standard-object) ())
309 (defclass generic-function
(dependent-update-mixin
310 definition-source-mixin
312 funcallable-standard-object
)
313 ((%documentation
:initform nil
:initarg
:documentation
)
314 ;; We need to make a distinction between the methods initially set
315 ;; up by :METHOD options to DEFGENERIC and the ones set up later by
316 ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
317 ;; an already-DEFGENERICed function clears the methods set by the
318 ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
319 ;; this distinction seems a little kludgy, but it has the positive
320 ;; effect of making it so that loading a file a.lisp containing
321 ;; DEFGENERIC, then loading a second file b.lisp containing
322 ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
323 ;; tends to leave the generic function in a state consistent with
324 ;; the most-recently-loaded state of a.lisp and b.lisp.)
325 (initial-methods :initform
() :accessor generic-function-initial-methods
)
326 (encapsulations :initform
() :accessor generic-function-encapsulations
))
327 (:metaclass funcallable-standard-class
))
329 (defclass standard-generic-function
(generic-function)
333 :reader generic-function-name
)
336 :accessor generic-function-methods
339 :initarg
:method-class
340 :accessor generic-function-method-class
)
342 :initarg
:method-combination
343 :accessor generic-function-method-combination
)
345 ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
346 ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning
347 ;; might be appropriate).
348 :initarg
:declarations
351 :accessor generic-function-declarations
)
353 :initform
(make-arg-info)
357 :accessor gf-dfun-state
)
358 ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
360 :initform
(sb-thread:make-mutex
:name
"GF lock")
362 (:metaclass funcallable-standard-class
)
363 (:default-initargs
:method-class
*the-class-standard-method
*
364 :method-combination
*standard-method-combination
*))
366 (defclass method
(metaobject) ())
368 (defclass standard-method
(plist-mixin definition-source-mixin method
)
369 ((%generic-function
:initform nil
:accessor method-generic-function
)
370 (qualifiers :initform
() :initarg
:qualifiers
:reader method-qualifiers
)
371 (specializers :initform
() :initarg
:specializers
372 :reader method-specializers
)
373 (lambda-list :initform
() :initarg
:lambda-list
:reader method-lambda-list
)
374 (%function
:initform nil
:initarg
:function
:reader method-function
)
375 (%documentation
:initform nil
:initarg
:documentation
)
376 ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or
377 ;; just a plain (CALL-NEXT-METHOD).
378 (simple-next-method-call
380 :initarg simple-next-method-call
381 :reader simple-next-method-call-p
)))
383 (defclass accessor-method
(standard-method)
384 ((slot-name :initform nil
:initarg
:slot-name
385 :reader accessor-method-slot-name
)))
387 (defclass standard-accessor-method
(accessor-method)
388 ((%slot-definition
:initform nil
:initarg
:slot-definition
389 :reader accessor-method-slot-definition
)))
391 (defclass standard-reader-method
(standard-accessor-method) ())
392 (defclass standard-writer-method
(standard-accessor-method) ())
393 ;;; an extension, apparently.
394 (defclass standard-boundp-method
(standard-accessor-method) ())
396 ;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
397 ;;; can't be STANDARD-READER-METHOD because there is no associated
399 (defclass global-reader-method
(accessor-method) ())
400 (defclass global-writer-method
(accessor-method) ())
401 (defclass global-boundp-method
(accessor-method) ())
403 (defclass method-combination
(metaobject)
404 ((%documentation
:initform nil
:initarg
:documentation
)))
406 (defclass standard-method-combination
(definition-source-mixin
409 :reader method-combination-type-name
412 :reader method-combination-options
415 (defclass long-method-combination
(standard-method-combination)
418 :reader long-method-combination-function
)
420 :initarg
:args-lambda-list
421 :reader long-method-combination-args-lambda-list
)))
423 (defclass short-method-combination
(standard-method-combination)
425 :reader short-combination-operator
427 (identity-with-one-argument
428 :reader short-combination-identity-with-one-argument
429 :initarg
:identity-with-one-argument
)))
431 (defclass slot-definition
(metaobject)
435 :accessor slot-definition-name
)
439 :accessor slot-definition-initform
)
442 :initarg
:initfunction
443 :accessor slot-definition-initfunction
)
447 :accessor slot-definition-initargs
)
448 (%type
:initform t
:initarg
:type
:accessor slot-definition-type
)
450 :initform nil
:initarg
:documentation
451 ;; KLUDGE: we need a reader for bootstrapping purposes, in
452 ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
453 :reader %slot-definition-documentation
)
454 (%class
:initform nil
:initarg
:class
:accessor slot-definition-class
)
455 (source :initform nil
:initarg source
:accessor definition-source
)))
457 (defclass standard-slot-definition
(slot-definition)
461 :accessor slot-definition-allocation
)
464 :initarg
:allocation-class
465 :accessor slot-definition-allocation-class
)))
467 (defclass condition-slot-definition
(slot-definition)
471 :accessor slot-definition-allocation
)
474 :initarg
:allocation-class
475 :accessor slot-definition-allocation-class
)))
477 (defclass structure-slot-definition
(slot-definition)
478 ((defstruct-accessor-symbol
480 :initarg
:defstruct-accessor-symbol
481 :accessor slot-definition-defstruct-accessor-symbol
)
482 (internal-reader-function
484 :initarg
:internal-reader-function
485 :accessor slot-definition-internal-reader-function
)
486 (internal-writer-function
488 :initarg
:internal-writer-function
489 :accessor slot-definition-internal-writer-function
)))
491 (defclass direct-slot-definition
(slot-definition)
495 :accessor slot-definition-readers
)
499 :accessor slot-definition-writers
)))
501 (defclass effective-slot-definition
(slot-definition)
505 :accessor slot-definition-info
)))
507 ;;; We use a structure here, because fast slot-accesses to this information
508 ;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
509 ;;; these functions can access the SLOT-INFO directly, avoiding the overhead
510 ;;; of accessing a standard-instance.
511 (defstruct (slot-info
512 (:constructor make-slot-info
513 (&key slotd typecheck
514 (reader (uninitialized-accessor-function :reader slotd
))
515 (writer (uninitialized-accessor-function :writer slotd
))
516 (boundp (uninitialized-accessor-function :boundp slotd
)))))
517 (typecheck nil
:type
(or null function
))
518 (reader (missing-arg) :type function
)
519 (writer (missing-arg) :type function
)
520 (boundp (missing-arg) :type function
))
522 (defclass standard-direct-slot-definition
(standard-slot-definition
523 direct-slot-definition
)
526 (defclass standard-effective-slot-definition
(standard-slot-definition
527 effective-slot-definition
)
528 ((location ; nil, a fixnum, a cons: (slot-name . value)
530 :accessor slot-definition-location
)))
532 (defclass condition-direct-slot-definition
(condition-slot-definition
533 direct-slot-definition
)
536 (defclass condition-effective-slot-definition
(condition-slot-definition
537 effective-slot-definition
)
540 (defclass structure-direct-slot-definition
(structure-slot-definition
541 direct-slot-definition
)
544 (defclass structure-effective-slot-definition
(structure-slot-definition
545 effective-slot-definition
)
548 (defclass specializer
(metaobject)
549 ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
550 ;; external symbol of the CL package and hence potentially collides
551 ;; with user code. Renaming this to %TYPE, however, is the coward's
552 ;; way out, because the objects that PCL puts in this slot aren't
553 ;; (quite) types: they are closer to kinds of specializer. However,
554 ;; the wholesale renaming and disentangling of specializers didn't
555 ;; appeal. (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
556 ;; responses in comp.lang.lisp). -- CSR, 2006-02-27
557 ((%type
:initform nil
:reader specializer-type
)))
559 ;;; STANDARD in this name doesn't mean "blessed by a standard" but
560 ;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
561 ;;; and vestiges of PROTOTYPE specializers
562 (defclass standard-specializer
(specializer) ())
564 ;;; Note that this class cannot define the OBJECT slot and
565 ;;; SPECIALIZER-OBJECT reader because of bootstrapping limitations.
566 (defclass specializer-with-object
(specializer) ())
568 (defclass exact-class-specializer
(specializer) ())
570 (defclass class-eq-specializer
(standard-specializer
571 exact-class-specializer
572 specializer-with-object
)
573 ((object :initarg
:class
574 :reader specializer-class
575 :reader specializer-object
)))
577 (defclass class-prototype-specializer
(standard-specializer
578 specializer-with-object
)
579 ((object :initarg
:class
580 :reader specializer-class
581 :reader specializer-object
)))
583 (defclass eql-specializer
(standard-specializer
584 exact-class-specializer
585 specializer-with-object
)
586 ((object :initarg
:object
:reader specializer-object
587 :reader eql-specializer-object
)
588 ;; Because EQL specializers are interned, any two putative instances
589 ;; of EQL-specializer referring to the same object are in fact EQ to
590 ;; each other. Therefore a list of direct methods in the specializer can
591 ;; reliably track all methods that are specialized on the identical object.
592 (direct-methods :initform
(cons nil nil
))))
594 ;; Why is this weak-value, not weak-key: suppose the value is unreachable (dead)
595 ;; but the key is reachable - this should allow dropping the entry, because
596 ;; you're indifferent to getting a fresh EQL specializer if you re-intern the
597 ;; same key. There's no way to know that you got a new VALUE, since the
598 ;; pre-condition of this case was that the old value was unreachable.
599 ;; KEY weakness is actually equivalent to KEY-OR-VALUE weakness, which would
600 ;; be less likely to drop the entry. The equivalence stems from the fact that
601 ;; holding the value (the specializer) also holds the key.
602 ;; Whereas, with :VALUE weakness, you can drop the specializer as soon as
603 ;; nothing needs it, even if OBJECT persists. You might think that calling
604 ;; gethash on a live key should get the identical specializer, but since
605 ;; nothing referenced the old specializer, consing a new one is fine.
606 (defglobal *eql-specializer-table
*
607 (make-hash-table :test
'eql
:weakness
:value
))
609 (defun intern-eql-specializer (object)
610 ;; Avoid style-warning about compiler-macro being unavailable.
611 (declare (notinline make-instance
))
612 ;; Need to lock, so that two threads don't get non-EQ specializers
613 ;; for an EQL object.
614 (with-locked-system-table (*eql-specializer-table
*)
615 (or (gethash object
*eql-specializer-table
*)
616 (setf (gethash object
*eql-specializer-table
*)
617 (make-instance 'eql-specializer
:object object
)))))
619 (defclass class
(dependent-update-mixin
620 definition-source-mixin
621 standard-specializer
)
626 (class-eq-specializer
628 :reader class-eq-specializer
)
631 :reader class-direct-superclasses
)
632 ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
633 ;; CONDITION-CLASSes are lazily computed whenever the subclass info
634 ;; becomes available, i.e. when the PCL class is created.
637 :reader class-direct-subclasses
)
639 :initform
(cons nil nil
))
642 :initarg
:documentation
)
643 ;; True if the class definition was compiled with a (SAFETY 3)
644 ;; optimization policy.
651 :reader class-finalized-p
)))
653 ;;; The class PCL-CLASS is an implementation-specific common
654 ;;; superclass of all specified subclasses of the class CLASS.
655 (defclass pcl-class
(class)
656 ((%class-precedence-list
657 :reader class-precedence-list
)
658 ;; KLUDGE: see note in CPL-OR-NIL
660 :reader cpl-available-p
664 :reader class-can-precede-list
)
665 (incompatible-superclass-list
667 :accessor class-incompatible-superclass-list
)
670 :reader class-wrapper
)
673 :reader class-prototype
)))
675 (defclass slot-class
(pcl-class)
678 :reader class-direct-slots
)
681 :reader class-slots
)))
683 ;;; The class STD-CLASS is an implementation-specific common
684 ;;; superclass of the classes STANDARD-CLASS and
685 ;;; FUNCALLABLE-STANDARD-CLASS.
686 (defclass std-class
(slot-class)
689 (defclass standard-class
(std-class)
692 :direct-superclasses
(list *the-class-standard-object
*)))
694 (defclass funcallable-standard-class
(std-class)
697 :direct-superclasses
(list *the-class-funcallable-standard-object
*)))
699 (defclass forward-referenced-class
(pcl-class) ())
701 (defclass system-class
(pcl-class) ())
703 (defclass built-in-class
(system-class) ())
705 (defclass condition-class
(slot-class) ())
707 (defclass structure-class
(slot-class)
708 ((defstruct-form :initform
() :accessor class-defstruct-form
)
709 (defstruct-constructor :initform nil
:accessor class-defstruct-constructor
)
710 (from-defclass-p :initform nil
:initarg
:from-defclass-p
)))
712 (defclass definition-source-mixin
(standard-object)
715 :reader definition-source
716 :initarg
:definition-source
)))
718 (defclass plist-mixin
(standard-object)
719 ((plist :initform
() :accessor object-plist
:initarg plist
)))
721 (defclass dependent-update-mixin
(plist-mixin) ())