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)
66 (setq args (cdr type) type (car type)))
68 (or (and (null args) (find-class type))
70 (class (coerce-to-class (car args)))
71 (prototype (make-instance 'class-prototype-specializer
72 :object (coerce-to-class (car args))))
73 (class-eq (class-eq-specializer (coerce-to-class (car args))))
74 (eql (intern-eql-specializer (car args))))))
75 ;; FIXME: do we still need this?
76 ((and (null args) (typep type 'classoid))
77 (or (classoid-pcl-class type)
78 (ensure-non-standard-class (classoid-name type))))
79 ((specializerp type) type)))
82 (defun type-from-specializer (specl)
86 (unless (member (car specl) '(class prototype class-eq eql))
87 (error "~S is not a legal specializer type." specl))
91 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
92 (setq specl (find-class specl)))
93 (or (not (eq *boot-state* 'complete))
94 (specializerp specl)))
95 (specializer-type specl))
97 (error "~S is neither a type nor a specializer." specl))))
99 (defun type-class (type)
100 (declare (special *the-class-t*))
101 (setq type (type-from-specializer type))
105 (error "bad argument to TYPE-CLASS"))
107 (eql (class-of (cadr type)))
108 (prototype (class-of (cadr type))) ;?
109 (class-eq (cadr type))
110 (class (cadr type)))))
112 (defun class-eq-type (class)
113 (specializer-type (class-eq-specializer class)))
115 ;;; internal to this file..
117 ;;; These functions are a pale imitation of their namesake. They accept
118 ;;; class objects or types where they should.
119 (defun *normalize-type (type)
121 (if (member (car type) '(not and or))
122 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
123 (if (null (cdr type))
124 (*normalize-type (car type))
127 (let ((class (find-class type nil)))
129 (let ((type (specializer-type class)))
130 (if (listp type) type `(,type)))
132 ((or (not (eq *boot-state* 'complete))
134 (specializer-type type))
136 (error "~S is not a type." type))))
138 ;;; internal to this file...
139 (defun convert-to-system-type (type)
141 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
143 ((class class-eq) ; class-eq is impossible to do right
144 (layout-classoid (class-wrapper (cadr type))))
146 (t (if (null (cdr type))
150 ;;; Writing the missing NOT and AND clauses will improve the quality
151 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
152 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
153 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
155 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
156 ;;; in the compiler. Could we share some of it here?
157 (defun *subtypep (type1 type2)
158 (if (equal type1 type2)
160 (if (eq *boot-state* 'early)
161 (values (eq type1 type2) t)
162 (let ((*in-precompute-effective-methods-p* t))
163 (declare (special *in-precompute-effective-methods-p*))
164 ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
165 ;; good name. It changes the way
166 ;; CLASS-APPLICABLE-USING-CLASS-P works.
167 (setq type1 (*normalize-type type1))
168 (setq type2 (*normalize-type type2))
171 (values nil nil)) ; XXX We should improve this.
173 (values nil nil)) ; XXX We should improve this.
174 ((eql wrapper-eq class-eq class)
175 (multiple-value-bind (app-p maybe-app-p)
176 (specializer-applicable-using-type-p type2 type1)
177 (values app-p (or app-p (not maybe-app-p)))))
179 (subtypep (convert-to-system-type type1)
180 (convert-to-system-type type2))))))))
182 (defvar *built-in-class-symbols* ())
183 (defvar *built-in-wrapper-symbols* ())
185 (defun get-built-in-class-symbol (class-name)
186 (or (cadr (assq class-name *built-in-class-symbols*))
187 (let ((symbol (make-class-symbol class-name)))
188 (push (list class-name symbol) *built-in-class-symbols*)
191 (defun get-built-in-wrapper-symbol (class-name)
192 (or (cadr (assq class-name *built-in-wrapper-symbols*))
193 (let ((symbol (make-wrapper-symbol class-name)))
194 (push (list class-name symbol) *built-in-wrapper-symbols*)
197 (pushnew '%class *var-declarations*)
198 (pushnew '%variable-rebinding *var-declarations*)
200 (defun variable-class (var env)
201 (caddr (var-declaration 'class var env)))
203 (defvar *standard-method-combination*)
205 (defun plist-value (object name)
206 (getf (object-plist object) name))
208 (defun (setf plist-value) (new-value object name)
210 (setf (getf (object-plist object) name) new-value)
212 (remf (object-plist object) name)
215 ;;;; built-in classes
217 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
218 ;;; SB-PCL:*BUILT-IN-CLASSES*.
219 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
220 (defvar *built-in-classes*
221 (labels ((direct-supers (class)
222 (/noshow "entering DIRECT-SUPERS" (classoid-name class))
223 (if (typep class 'built-in-classoid)
224 (built-in-classoid-direct-superclasses class)
225 (let ((inherits (layout-inherits
226 (classoid-layout class))))
228 (list (svref inherits (1- (length inherits)))))))
230 (/noshow "entering DIRECT-SUBS" (classoid-name class))
232 (let ((subs (classoid-subclasses class)))
238 (when (member class (direct-supers sub))
241 (mapcar (lambda (kernel-bic-entry)
242 (/noshow "setting up" kernel-bic-entry)
243 (let* ((name (car kernel-bic-entry))
244 (class (find-classoid name))
246 (getf (cdr kernel-bic-entry) :prototype-form)))
249 ,(mapcar #'classoid-name (direct-supers class))
250 ,(mapcar #'classoid-name (direct-subs class))
254 (layout-classoid x)))
257 (classoid-layout class))))
259 (eval prototype-form)
260 ;; This is the default prototype value which
261 ;; was used, without explanation, by the CMU CL
262 ;; code we're derived from. Evidently it's safe
263 ;; in all relevant cases.
265 (remove-if (lambda (kernel-bic-entry)
266 (member (first kernel-bic-entry)
267 ;; I'm not sure why these are removed from
268 ;; the list, but that's what the original
269 ;; CMU CL code did. -- WHN 20000715
271 file-stream string-stream)))
272 sb-kernel::*built-in-classes*))))
273 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
275 ;;;; the classes that define the kernel of the metabraid
278 (:metaclass built-in-class))
280 (defclass function (t) ()
281 (:metaclass built-in-class))
283 (defclass stream (t) ()
284 (:metaclass built-in-class))
286 (defclass file-stream (stream) ()
287 (:metaclass built-in-class))
289 (defclass string-stream (stream) ()
290 (:metaclass built-in-class))
292 (defclass slot-object (t) ()
293 (:metaclass slot-class))
295 (defclass condition (slot-object) ()
296 (:metaclass condition-class))
298 (defclass structure-object (slot-object) ()
299 (:metaclass structure-class))
301 (defstruct (dead-beef-structure-object
302 (:constructor |STRUCTURE-OBJECT class constructor|)
305 (defclass standard-object (slot-object) ())
307 (defclass funcallable-standard-object (function standard-object)
309 (:metaclass funcallable-standard-class))
311 (defclass metaobject (standard-object) ())
313 (defclass generic-function (dependent-update-mixin
314 definition-source-mixin
316 funcallable-standard-object)
319 :initarg :documentation)
320 ;; We need to make a distinction between the methods initially set
321 ;; up by :METHOD options to DEFGENERIC and the ones set up later by
322 ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
323 ;; an already-DEFGENERICed function clears the methods set by the
324 ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
325 ;; this distinction seems a little kludgy, but it has the positive
326 ;; effect of making it so that loading a file a.lisp containing
327 ;; DEFGENERIC, then loading a second file b.lisp containing
328 ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
329 ;; tends to leave the generic function in a state consistent with
330 ;; the most-recently-loaded state of a.lisp and b.lisp.)
333 :accessor generic-function-initial-methods))
334 (:metaclass funcallable-standard-class))
336 (defclass standard-generic-function (generic-function)
340 :reader generic-function-name)
343 :accessor generic-function-methods
346 :initarg :method-class
347 :accessor generic-function-method-class)
349 :initarg :method-combination
350 :accessor generic-function-method-combination)
352 ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
353 ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning
354 ;; might be appropriate).
355 :initarg :declarations
358 :accessor generic-function-declarations)
360 :initform (make-arg-info)
364 :accessor gf-dfun-state)
365 ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
367 :initform (sb-thread::make-spinlock :name "GF lock")
369 (:metaclass funcallable-standard-class)
370 (:default-initargs :method-class *the-class-standard-method*
371 :method-combination *standard-method-combination*))
373 (defclass method (metaobject) ())
375 (defclass standard-method (plist-mixin definition-source-mixin method)
378 :accessor method-generic-function)
382 :reader method-qualifiers)
385 :initarg :specializers
386 :reader method-specializers)
389 :initarg :lambda-list
390 :reader method-lambda-list)
391 (%function :initform nil :initarg :function :reader method-function)
392 (%documentation :initform nil :initarg :documentation)))
394 (defclass accessor-method (standard-method)
395 ((slot-name :initform nil :initarg :slot-name
396 :reader accessor-method-slot-name)))
398 (defclass standard-accessor-method (accessor-method)
399 ((%slot-definition :initform nil :initarg :slot-definition
400 :reader accessor-method-slot-definition)))
402 (defclass standard-reader-method (standard-accessor-method) ())
403 (defclass standard-writer-method (standard-accessor-method) ())
404 ;;; an extension, apparently.
405 (defclass standard-boundp-method (standard-accessor-method) ())
407 ;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
408 ;;; can't be STANDARD-READER-METHOD because there is no associated
410 (defclass global-reader-method (accessor-method) ())
411 (defclass global-writer-method (accessor-method) ())
412 (defclass global-boundp-method (accessor-method) ())
414 (defclass method-combination (metaobject)
415 ((%documentation :initform nil :initarg :documentation)))
417 (defclass standard-method-combination (definition-source-mixin
420 :reader method-combination-type-name
423 :reader method-combination-options
426 (defclass long-method-combination (standard-method-combination)
429 :reader long-method-combination-function)
431 :initarg :args-lambda-list
432 :reader long-method-combination-args-lambda-list)))
434 (defclass short-method-combination (standard-method-combination)
436 :reader short-combination-operator
438 (identity-with-one-argument
439 :reader short-combination-identity-with-one-argument
440 :initarg :identity-with-one-argument)))
442 (defclass slot-definition (metaobject)
446 :accessor slot-definition-name)
450 :accessor slot-definition-initform)
453 :initarg :initfunction
454 :accessor slot-definition-initfunction)
458 :accessor slot-definition-readers)
462 :accessor slot-definition-writers)
466 :accessor slot-definition-initargs)
467 (%type :initform t :initarg :type :accessor slot-definition-type)
468 (%type-check-function :initform nil
469 :initarg type-check-function
470 :accessor slot-definition-type-check-function)
472 :initform nil :initarg :documentation
473 ;; KLUDGE: we need a reader for bootstrapping purposes, in
474 ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
475 :reader %slot-definition-documentation)
476 (%class :initform nil :initarg :class :accessor slot-definition-class)))
478 (defclass standard-slot-definition (slot-definition)
482 :accessor slot-definition-allocation)
485 :initarg :allocation-class
486 :accessor slot-definition-allocation-class)))
488 (defclass condition-slot-definition (slot-definition)
492 :accessor slot-definition-allocation)
495 :initarg :allocation-class
496 :accessor slot-definition-allocation-class)))
498 (defclass structure-slot-definition (slot-definition)
499 ((defstruct-accessor-symbol
501 :initarg :defstruct-accessor-symbol
502 :accessor slot-definition-defstruct-accessor-symbol)
503 (internal-reader-function
505 :initarg :internal-reader-function
506 :accessor slot-definition-internal-reader-function)
507 (internal-writer-function
509 :initarg :internal-writer-function
510 :accessor slot-definition-internal-writer-function)))
512 (defclass direct-slot-definition (slot-definition)
515 (defclass effective-slot-definition (slot-definition)
516 ((reader-function ; (lambda (object) ...)
517 :accessor slot-definition-reader-function)
518 (writer-function ; (lambda (new-value object) ...)
519 :accessor slot-definition-writer-function)
520 (boundp-function ; (lambda (object) ...)
521 :accessor slot-definition-boundp-function)
525 (defclass standard-direct-slot-definition (standard-slot-definition
526 direct-slot-definition)
529 (defclass standard-effective-slot-definition (standard-slot-definition
530 effective-slot-definition)
531 ((location ; nil, a fixnum, a cons: (slot-name . value)
533 :accessor slot-definition-location)))
535 (defclass condition-direct-slot-definition (condition-slot-definition
536 direct-slot-definition)
539 (defclass condition-effective-slot-definition (condition-slot-definition
540 effective-slot-definition)
543 (defclass structure-direct-slot-definition (structure-slot-definition
544 direct-slot-definition)
547 (defclass structure-effective-slot-definition (structure-slot-definition
548 effective-slot-definition)
551 (defclass specializer (metaobject)
552 ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
553 ;; external symbol of the CL package and hence potentially collides
554 ;; with user code. Renaming this to %TYPE, however, is the coward's
555 ;; way out, because the objects that PCL puts in this slot aren't
556 ;; (quite) types: they are closer to kinds of specializer. However,
557 ;; the wholesale renaming and disentangling of specializers didn't
558 ;; appeal. (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
559 ;; responses in comp.lang.lisp). -- CSR, 2006-02-27
560 ((%type :initform nil :reader specializer-type)))
562 (defclass specializer-with-object (specializer) ())
564 (defclass exact-class-specializer (specializer) ())
566 (defclass class-eq-specializer (exact-class-specializer
567 specializer-with-object)
568 ((object :initarg :class
569 :reader specializer-class
570 :reader specializer-object)))
572 (defclass class-prototype-specializer (specializer-with-object)
573 ((object :initarg :class
574 :reader specializer-class
575 :reader specializer-object)))
577 (defclass eql-specializer (exact-class-specializer specializer-with-object)
578 ((object :initarg :object :reader specializer-object
579 :reader eql-specializer-object)))
581 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
583 (defun intern-eql-specializer (object)
584 (or (gethash object *eql-specializer-table*)
585 (setf (gethash object *eql-specializer-table*)
586 (make-instance 'eql-specializer :object object))))
588 (defclass class (dependent-update-mixin
589 definition-source-mixin
595 (class-eq-specializer
597 :reader class-eq-specializer)
600 :reader class-direct-superclasses)
601 ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
602 ;; CONDITION-CLASSes are lazily computed whenever the subclass info
603 ;; becomes available, i.e. when the PCL class is created.
606 :reader class-direct-subclasses)
608 :initform (cons nil nil))
611 :initarg :documentation)
612 ;; True if the class definition was compiled with a (SAFETY 3)
613 ;; optimization policy.
620 :reader class-finalized-p)))
622 (def!method make-load-form ((class class) &optional env)
623 ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
624 ;; doesn't matter while all our environments are the same...
625 (declare (ignore env))
626 (let ((name (class-name class)))
627 (unless (and name (eq (find-class name nil) class))
628 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
630 `(find-class ',name)))
632 ;;; The class PCL-CLASS is an implementation-specific common
633 ;;; superclass of all specified subclasses of the class CLASS.
634 (defclass pcl-class (class)
635 ((%class-precedence-list
636 :reader class-precedence-list)
637 ;; KLUDGE: see note in CPL-OR-NIL
639 :reader cpl-available-p
643 :reader class-can-precede-list)
644 (incompatible-superclass-list
646 :accessor class-incompatible-superclass-list)
649 :reader class-wrapper)
652 :reader class-prototype)))
654 (defclass slot-class (pcl-class)
657 :accessor class-direct-slots)
660 :accessor class-slots)))
662 ;;; The class STD-CLASS is an implementation-specific common
663 ;;; superclass of the classes STANDARD-CLASS and
664 ;;; FUNCALLABLE-STANDARD-CLASS.
665 (defclass std-class (slot-class)
668 (defclass standard-class (std-class)
671 (defclass funcallable-standard-class (std-class)
674 (defclass forward-referenced-class (pcl-class) ())
676 (defclass built-in-class (pcl-class) ())
678 (defclass condition-class (slot-class) ())
680 (defclass structure-class (slot-class)
683 :accessor class-defstruct-form)
684 (defstruct-constructor
686 :accessor class-defstruct-constructor)
689 :initarg :from-defclass-p)))
691 (defclass definition-source-mixin (standard-object)
694 :reader definition-source
695 :initarg :definition-source)))
697 (defclass plist-mixin (standard-object)
698 ((plist :initform () :accessor object-plist :initarg plist)))
700 (defclass dependent-update-mixin (plist-mixin) ())
702 (defparameter *early-class-predicates*
703 '((specializer specializerp)
704 (exact-class-specializer exact-class-specializer-p)
705 (class-eq-specializer class-eq-specializer-p)
706 (eql-specializer eql-specializer-p)
708 (slot-class slot-class-p)
709 (std-class std-class-p)
710 (standard-class standard-class-p)
711 (funcallable-standard-class funcallable-standard-class-p)
712 (condition-class condition-class-p)
713 (structure-class structure-class-p)
714 (forward-referenced-class forward-referenced-class-p)
716 (standard-method standard-method-p)
717 (accessor-method accessor-method-p)
718 (standard-accessor-method standard-accessor-method-p)
719 (standard-reader-method standard-reader-method-p)
720 (standard-writer-method standard-writer-method-p)
721 (standard-boundp-method standard-boundp-method-p)
722 (global-reader-method global-reader-method-p)
723 (global-writer-method global-writer-method-p)
724 (global-boundp-method global-boundp-method-p)
725 (generic-function generic-function-p)
726 (standard-generic-function standard-generic-function-p)
727 (method-combination method-combination-p)
728 (long-method-combination long-method-combination-p)
729 (short-method-combination short-method-combination-p)))