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 ;;; comments from CMU CL version of PCL:
42 ;;; This is like fdefinition on the Lispm. If Common Lisp had
43 ;;; something like function specs I wouldn't need this. On the other
44 ;;; hand, I don't like the way this really works so maybe function
45 ;;; specs aren't really right either?
46 ;;; I also don't understand the real implications of a Lisp-1 on this
47 ;;; sort of thing. Certainly some of the lossage in all of this is
48 ;;; because these SPECs name global definitions.
49 ;;; Note that this implementation is set up so that an implementation
50 ;;; which has a 'real' function spec mechanism can use that instead
51 ;;; and in that way get rid of setf generic function names.
52 (defmacro parse-gspec (spec
53 (non-setf-var . non-setf-case))
54 `(let ((,non-setf-var ,spec)) ,@non-setf-case))
56 ;;; If symbol names a function which is traced, return the untraced
57 ;;; definition. This lets us get at the generic function object even
58 ;;; when it is traced.
59 (defun unencapsulated-fdefinition (symbol)
62 ;;; If symbol names a function which is traced, redefine the `real'
63 ;;; definition without affecting the trace.
64 (defun fdefine-carefully (name new-definition)
66 (sb-c::note-name-defined name :function)
68 (setf (fdefinition name) new-definition))
72 (name (fboundp name))))
74 (defun gmakunbound (spec)
76 (name (fmakunbound name))))
78 (defun gdefinition (spec)
80 (name (unencapsulated-fdefinition name))))
82 (defun (setf gdefinition) (new-value spec)
84 (name (fdefine-carefully name new-value))))
86 (declaim (special *the-class-t*
87 *the-class-vector* *the-class-symbol*
88 *the-class-string* *the-class-sequence*
89 *the-class-rational* *the-class-ratio*
90 *the-class-number* *the-class-null* *the-class-list*
91 *the-class-integer* *the-class-float* *the-class-cons*
92 *the-class-complex* *the-class-character*
93 *the-class-bit-vector* *the-class-array*
96 *the-class-slot-object*
97 *the-class-structure-object*
98 *the-class-std-object*
99 *the-class-standard-object*
100 *the-class-funcallable-standard-object*
102 *the-class-generic-function*
103 *the-class-built-in-class*
104 *the-class-slot-class*
105 *the-class-condition-class*
106 *the-class-structure-class*
107 *the-class-std-class*
108 *the-class-standard-class*
109 *the-class-funcallable-standard-class*
111 *the-class-standard-method*
112 *the-class-standard-reader-method*
113 *the-class-standard-writer-method*
114 *the-class-standard-boundp-method*
115 *the-class-standard-generic-function*
116 *the-class-standard-effective-slot-definition*
118 *the-eslotd-standard-class-slots*
119 *the-eslotd-funcallable-standard-class-slots*))
121 (declaim (special *the-wrapper-of-t*
122 *the-wrapper-of-vector* *the-wrapper-of-symbol*
123 *the-wrapper-of-string* *the-wrapper-of-sequence*
124 *the-wrapper-of-rational* *the-wrapper-of-ratio*
125 *the-wrapper-of-number* *the-wrapper-of-null*
126 *the-wrapper-of-list* *the-wrapper-of-integer*
127 *the-wrapper-of-float* *the-wrapper-of-cons*
128 *the-wrapper-of-complex* *the-wrapper-of-character*
129 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
131 ;;;; type specifier hackery
133 ;;; internal to this file
134 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
136 (or (find-class class (not make-forward-referenced-class-p))
137 (ensure-class class))
141 (defun specializer-from-type (type &aux args)
143 (setq args (cdr type) type (car type)))
144 (cond ((symbolp type)
145 (or (and (null args) (find-class type))
147 (class (coerce-to-class (car args)))
148 (prototype (make-instance 'class-prototype-specializer
149 :object (coerce-to-class (car args))))
150 (class-eq (class-eq-specializer (coerce-to-class (car args))))
151 (eql (intern-eql-specializer (car args))))))
152 ;; FIXME: do we still need this?
153 ((and (null args) (typep type 'classoid))
154 (or (classoid-pcl-class type)
155 (ensure-non-standard-class (classoid-name type))))
156 ((specializerp type) type)))
159 (defun type-from-specializer (specl)
163 (unless (member (car specl) '(class prototype class-eq eql))
164 (error "~S is not a legal specializer type." specl))
167 (when (symbolp specl)
168 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
169 (setq specl (find-class specl)))
170 (or (not (eq *boot-state* 'complete))
171 (specializerp specl)))
172 (specializer-type specl))
174 (error "~S is neither a type nor a specializer." specl))))
176 (defun type-class (type)
177 (declare (special *the-class-t*))
178 (setq type (type-from-specializer type))
182 (error "bad argument to TYPE-CLASS"))
184 (eql (class-of (cadr type)))
185 (prototype (class-of (cadr type))) ;?
186 (class-eq (cadr type))
187 (class (cadr type)))))
189 (defun class-eq-type (class)
190 (specializer-type (class-eq-specializer class)))
192 ;;; internal to this file..
194 ;;; These functions are a pale imitation of their namesake. They accept
195 ;;; class objects or types where they should.
196 (defun *normalize-type (type)
198 (if (member (car type) '(not and or))
199 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
200 (if (null (cdr type))
201 (*normalize-type (car type))
204 (let ((class (find-class type nil)))
206 (let ((type (specializer-type class)))
207 (if (listp type) type `(,type)))
209 ((or (not (eq *boot-state* 'complete))
211 (specializer-type type))
213 (error "~S is not a type." type))))
215 ;;; internal to this file...
216 (defun convert-to-system-type (type)
218 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
220 ((class class-eq) ; class-eq is impossible to do right
221 (layout-classoid (class-wrapper (cadr type))))
223 (t (if (null (cdr type))
227 ;;; Writing the missing NOT and AND clauses will improve the quality
228 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
229 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
230 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
232 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
233 ;;; in the compiler. Could we share some of it here?
234 (defun *subtypep (type1 type2)
235 (if (equal type1 type2)
237 (if (eq *boot-state* 'early)
238 (values (eq type1 type2) t)
239 (let ((*in-precompute-effective-methods-p* t))
240 (declare (special *in-precompute-effective-methods-p*))
241 ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
242 ;; good name. It changes the way
243 ;; CLASS-APPLICABLE-USING-CLASS-P works.
244 (setq type1 (*normalize-type type1))
245 (setq type2 (*normalize-type type2))
248 (values nil nil)) ; XXX We should improve this.
250 (values nil nil)) ; XXX We should improve this.
251 ((eql wrapper-eq class-eq class)
252 (multiple-value-bind (app-p maybe-app-p)
253 (specializer-applicable-using-type-p type2 type1)
254 (values app-p (or app-p (not maybe-app-p)))))
256 (subtypep (convert-to-system-type type1)
257 (convert-to-system-type type2))))))))
259 (defvar *built-in-class-symbols* ())
260 (defvar *built-in-wrapper-symbols* ())
262 (defun get-built-in-class-symbol (class-name)
263 (or (cadr (assq class-name *built-in-class-symbols*))
264 (let ((symbol (intern (format nil
266 (symbol-name class-name))
268 (push (list class-name symbol) *built-in-class-symbols*)
271 (defun get-built-in-wrapper-symbol (class-name)
272 (or (cadr (assq class-name *built-in-wrapper-symbols*))
273 (let ((symbol (intern (format nil
274 "*THE-WRAPPER-OF-~A*"
275 (symbol-name class-name))
277 (push (list class-name symbol) *built-in-wrapper-symbols*)
280 (pushnew '%class *var-declarations*)
281 (pushnew '%variable-rebinding *var-declarations*)
283 (defun variable-class (var env)
284 (caddr (var-declaration 'class var env)))
286 (defvar *name->class->slotd-table* (make-hash-table))
288 (defvar *standard-method-combination*)
290 (defun make-class-predicate-name (name)
291 (list 'class-predicate name))
293 (defun plist-value (object name)
294 (getf (object-plist object) name))
296 (defun (setf plist-value) (new-value object name)
298 (setf (getf (object-plist object) name) new-value)
300 (remf (object-plist object) name)
303 ;;;; built-in classes
305 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
306 ;;; SB-PCL:*BUILT-IN-CLASSES*.
307 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
308 (defvar *built-in-classes*
309 (labels ((direct-supers (class)
310 (/noshow "entering DIRECT-SUPERS" (classoid-name class))
311 (if (typep class 'built-in-classoid)
312 (built-in-classoid-direct-superclasses class)
313 (let ((inherits (layout-inherits
314 (classoid-layout class))))
316 (list (svref inherits (1- (length inherits)))))))
318 (/noshow "entering DIRECT-SUBS" (classoid-name class))
320 (let ((subs (classoid-subclasses class)))
326 (when (member class (direct-supers sub))
329 (mapcar (lambda (kernel-bic-entry)
330 (/noshow "setting up" kernel-bic-entry)
331 (let* ((name (car kernel-bic-entry))
332 (class (find-classoid name))
334 (getf (cdr kernel-bic-entry) :prototype-form)))
337 ,(mapcar #'classoid-name (direct-supers class))
338 ,(mapcar #'classoid-name (direct-subs class))
342 (layout-classoid x)))
345 (classoid-layout class))))
347 (eval prototype-form)
348 ;; This is the default prototype value which
349 ;; was used, without explanation, by the CMU CL
350 ;; code we're derived from. Evidently it's safe
351 ;; in all relevant cases.
353 (remove-if (lambda (kernel-bic-entry)
354 (member (first kernel-bic-entry)
355 ;; I'm not sure why these are removed from
356 ;; the list, but that's what the original
357 ;; CMU CL code did. -- WHN 20000715
361 sb-kernel::*built-in-classes*))))
362 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
364 ;;;; the classes that define the kernel of the metabraid
367 (:metaclass built-in-class))
369 (defclass instance (t) ()
370 (:metaclass built-in-class))
372 (defclass function (t) ()
373 (:metaclass built-in-class))
375 (defclass funcallable-instance (function) ()
376 (:metaclass built-in-class))
378 (defclass stream (instance) ()
379 (:metaclass built-in-class))
381 (defclass slot-object (t) ()
382 (:metaclass slot-class))
384 (defclass condition (slot-object instance) ()
385 (:metaclass condition-class))
387 (defclass structure-object (slot-object instance) ()
388 (:metaclass structure-class))
390 (defstruct (dead-beef-structure-object
391 (:constructor |STRUCTURE-OBJECT class constructor|)
394 (defclass std-object (slot-object) ()
395 (:metaclass std-class))
397 (defclass standard-object (std-object instance) ())
399 (defclass funcallable-standard-object (std-object funcallable-instance)
401 (:metaclass funcallable-standard-class))
403 (defclass specializer (standard-object)
406 :reader specializer-type)))
408 (defclass definition-source-mixin (std-object)
410 :initform *load-pathname*
411 :reader definition-source
412 :initarg :definition-source))
413 (:metaclass std-class))
415 (defclass plist-mixin (std-object)
418 :accessor object-plist))
419 (:metaclass std-class))
421 (defclass dependent-update-mixin (plist-mixin)
423 (:metaclass std-class))
425 ;;; The class CLASS is a specified basic class. It is the common
426 ;;; superclass of any kind of class. That is, any class that can be a
427 ;;; metaclass must have the class CLASS in its class precedence list.
428 (defclass class (dependent-update-mixin
429 definition-source-mixin
434 :accessor class-name)
435 (class-eq-specializer
437 :reader class-eq-specializer)
440 :reader class-direct-superclasses)
441 ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
442 ;; CONDITION-CLASSes are lazily computed whenever the subclass info
443 ;; becomes available, i.e. when the PCL class is created.
446 :reader class-direct-subclasses)
448 :initform (cons nil nil))
451 :reader class-predicate-name)
454 :initarg :documentation)
457 :reader class-finalized-p)))
459 (def!method make-load-form ((class class) &optional env)
460 ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
461 ;; doesn't matter while all our environments are the same...
462 (declare (ignore env))
463 (let ((name (class-name class)))
464 (unless (and name (eq (find-class name nil) class))
465 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
467 `(find-class ',name)))
469 ;;; The class PCL-CLASS is an implementation-specific common
470 ;;; superclass of all specified subclasses of the class CLASS.
471 (defclass pcl-class (class)
472 ((class-precedence-list
473 :reader class-precedence-list)
476 :reader class-can-precede-list)
477 (incompatible-superclass-list
479 :accessor class-incompatible-superclass-list)
482 :reader class-wrapper)
485 :reader class-prototype)))
487 (defclass slot-class (pcl-class)
490 :accessor class-direct-slots)
493 :accessor class-slots)))
495 ;;; The class STD-CLASS is an implementation-specific common
496 ;;; superclass of the classes STANDARD-CLASS and
497 ;;; FUNCALLABLE-STANDARD-CLASS.
498 (defclass std-class (slot-class)
501 (defclass standard-class (std-class)
504 (defclass funcallable-standard-class (std-class)
507 (defclass forward-referenced-class (pcl-class) ())
509 (defclass built-in-class (pcl-class) ())
511 (defclass condition-class (slot-class) ())
513 (defclass structure-class (slot-class)
516 :accessor class-defstruct-form)
517 (defstruct-constructor
519 :accessor class-defstruct-constructor)
522 :initarg :from-defclass-p)))
524 (defclass specializer-with-object (specializer) ())
526 (defclass exact-class-specializer (specializer) ())
528 (defclass class-eq-specializer (exact-class-specializer
529 specializer-with-object)
530 ((object :initarg :class
531 :reader specializer-class
532 :reader specializer-object)))
534 (defclass class-prototype-specializer (specializer-with-object)
535 ((object :initarg :class
536 :reader specializer-class
537 :reader specializer-object)))
539 (defclass eql-specializer (exact-class-specializer specializer-with-object)
540 ((object :initarg :object :reader specializer-object
541 :reader eql-specializer-object)))
543 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
545 (defun intern-eql-specializer (object)
546 (or (gethash object *eql-specializer-table*)
547 (setf (gethash object *eql-specializer-table*)
548 (make-instance 'eql-specializer :object object))))
550 ;;;; slot definitions
552 (defclass slot-definition (standard-object)
556 :accessor slot-definition-name)
560 :accessor slot-definition-initform)
563 :initarg :initfunction
564 :accessor slot-definition-initfunction)
568 :accessor slot-definition-readers)
572 :accessor slot-definition-writers)
576 :accessor slot-definition-initargs)
580 :accessor slot-definition-type)
583 :initarg :documentation)
587 :accessor slot-definition-class)))
589 (defclass standard-slot-definition (slot-definition)
593 :accessor slot-definition-allocation)
596 :initarg :allocation-class
597 :accessor slot-definition-allocation-class)))
599 (defclass condition-slot-definition (slot-definition)
603 :accessor slot-definition-allocation)
606 :initarg :allocation-class
607 :accessor slot-definition-allocation-class)))
609 (defclass structure-slot-definition (slot-definition)
610 ((defstruct-accessor-symbol
612 :initarg :defstruct-accessor-symbol
613 :accessor slot-definition-defstruct-accessor-symbol)
614 (internal-reader-function
616 :initarg :internal-reader-function
617 :accessor slot-definition-internal-reader-function)
618 (internal-writer-function
620 :initarg :internal-writer-function
621 :accessor slot-definition-internal-writer-function)))
623 (defclass direct-slot-definition (slot-definition)
626 (defclass effective-slot-definition (slot-definition)
627 ((reader-function ; (lambda (object) ...)
628 :accessor slot-definition-reader-function)
629 (writer-function ; (lambda (new-value object) ...)
630 :accessor slot-definition-writer-function)
631 (boundp-function ; (lambda (object) ...)
632 :accessor slot-definition-boundp-function)
636 (defclass standard-direct-slot-definition (standard-slot-definition
637 direct-slot-definition)
640 (defclass standard-effective-slot-definition (standard-slot-definition
641 effective-slot-definition)
642 ((location ; nil, a fixnum, a cons: (slot-name . value)
644 :accessor slot-definition-location)))
646 (defclass condition-direct-slot-definition (condition-slot-definition
647 direct-slot-definition)
650 (defclass condition-effective-slot-definition (condition-slot-definition
651 effective-slot-definition)
654 (defclass structure-direct-slot-definition (structure-slot-definition
655 direct-slot-definition)
658 (defclass structure-effective-slot-definition (structure-slot-definition
659 effective-slot-definition)
662 (defclass method (standard-object) ())
664 (defclass standard-method (definition-source-mixin plist-mixin method)
667 :accessor method-generic-function)
670 ;;; :initarg :qualifiers
671 ;;; :reader method-qualifiers)
674 :initarg :specializers
675 :reader method-specializers)
678 :initarg :lambda-list
679 :reader method-lambda-list)
682 :initarg :function) ;no writer
685 :initarg :fast-function ;no writer
686 :reader method-fast-function)
689 :initarg :documentation)))
691 (defclass standard-accessor-method (standard-method)
692 ((slot-name :initform nil
694 :reader accessor-method-slot-name)
695 (slot-definition :initform nil
696 :initarg :slot-definition
697 :reader accessor-method-slot-definition)))
699 (defclass standard-reader-method (standard-accessor-method) ())
701 (defclass standard-writer-method (standard-accessor-method) ())
703 (defclass standard-boundp-method (standard-accessor-method) ())
705 (defclass generic-function (dependent-update-mixin
706 definition-source-mixin
707 funcallable-standard-object)
710 :initarg :documentation)
711 ;; We need to make a distinction between the methods initially set
712 ;; up by :METHOD options to DEFGENERIC and the ones set up later by
713 ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
714 ;; an already-DEFGENERICed function clears the methods set by the
715 ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
716 ;; this distinction seems a little kludgy, but it has the positive
717 ;; effect of making it so that loading a file a.lisp containing
718 ;; DEFGENERIC, then loading a second file b.lisp containing
719 ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
720 ;; tends to leave the generic function in a state consistent with
721 ;; the most-recently-loaded state of a.lisp and b.lisp.)
724 :accessor generic-function-initial-methods))
725 (:metaclass funcallable-standard-class))
727 (defclass standard-generic-function (generic-function)
731 :accessor generic-function-name)
734 :accessor generic-function-methods
737 :initarg :method-class
738 :accessor generic-function-method-class)
740 :initarg :method-combination
741 :accessor generic-function-method-combination)
743 :initarg :declarations
745 :accessor generic-function-declarations)
747 :initform (make-arg-info)
751 :accessor gf-dfun-state))
752 (:metaclass funcallable-standard-class)
753 (:default-initargs :method-class *the-class-standard-method*
754 :method-combination *standard-method-combination*))
756 (defclass method-combination (standard-object)
758 :reader method-combination-documentation
760 :initarg :documentation)))
762 (defclass standard-method-combination (definition-source-mixin
765 :reader method-combination-type
768 :reader method-combination-options
771 (defclass long-method-combination (standard-method-combination)
774 :reader long-method-combination-function)
776 :initarg :args-lambda-list
777 :reader long-method-combination-args-lambda-list)))
779 (defparameter *early-class-predicates*
780 '((specializer specializerp)
781 (exact-class-specializer exact-class-specializer-p)
782 (class-eq-specializer class-eq-specializer-p)
783 (eql-specializer eql-specializer-p)
785 (slot-class slot-class-p)
786 (std-class std-class-p)
787 (standard-class standard-class-p)
788 (funcallable-standard-class funcallable-standard-class-p)
789 (condition-class condition-class-p)
790 (structure-class structure-class-p)
791 (forward-referenced-class forward-referenced-class-p)
793 (standard-method standard-method-p)
794 (standard-accessor-method standard-accessor-method-p)
795 (standard-reader-method standard-reader-method-p)
796 (standard-writer-method standard-writer-method-p)
797 (standard-boundp-method standard-boundp-method-p)
798 (generic-function generic-function-p)
799 (standard-generic-function standard-generic-function-p)
800 (method-combination method-combination-p)
801 (long-method-combination long-method-combination-p)))