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-structure-class*
106 *the-class-std-class*
107 *the-class-standard-class*
108 *the-class-funcallable-standard-class*
110 *the-class-standard-method*
111 *the-class-standard-reader-method*
112 *the-class-standard-writer-method*
113 *the-class-standard-boundp-method*
114 *the-class-standard-generic-function*
115 *the-class-standard-effective-slot-definition*
117 *the-eslotd-standard-class-slots*
118 *the-eslotd-funcallable-standard-class-slots*))
120 (declaim (special *the-wrapper-of-t*
121 *the-wrapper-of-vector* *the-wrapper-of-symbol*
122 *the-wrapper-of-string* *the-wrapper-of-sequence*
123 *the-wrapper-of-rational* *the-wrapper-of-ratio*
124 *the-wrapper-of-number* *the-wrapper-of-null*
125 *the-wrapper-of-list* *the-wrapper-of-integer*
126 *the-wrapper-of-float* *the-wrapper-of-cons*
127 *the-wrapper-of-complex* *the-wrapper-of-character*
128 *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
130 ;;;; type specifier hackery
132 ;;; internal to this file
133 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
135 (or (find-class class (not make-forward-referenced-class-p))
136 (ensure-class class))
140 (defun specializer-from-type (type &aux args)
142 (setq args (cdr type) type (car type)))
143 (cond ((symbolp type)
144 (or (and (null args) (find-class type))
146 (class (coerce-to-class (car args)))
147 (prototype (make-instance 'class-prototype-specializer
148 :object (coerce-to-class (car args))))
149 (class-eq (class-eq-specializer (coerce-to-class (car args))))
150 (eql (intern-eql-specializer (car args))))))
151 ((and (null args) (typep type 'cl:class))
152 (or (sb-kernel:class-pcl-class type)
153 (find-structure-class (cl:class-name type))))
154 ((specializerp type) type)))
157 (defun type-from-specializer (specl)
161 (unless (member (car specl) '(class prototype class-eq eql))
162 (error "~S is not a legal specializer type." specl))
165 (when (symbolp specl)
166 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
167 (setq specl (find-class specl)))
168 (or (not (eq *boot-state* 'complete))
169 (specializerp specl)))
170 (specializer-type specl))
172 (error "~S is neither a type nor a specializer." specl))))
174 (defun type-class (type)
175 (declare (special *the-class-t*))
176 (setq type (type-from-specializer type))
180 (error "bad argument to TYPE-CLASS"))
182 (eql (class-of (cadr type)))
183 (prototype (class-of (cadr type))) ;?
184 (class-eq (cadr type))
185 (class (cadr type)))))
187 (defun class-eq-type (class)
188 (specializer-type (class-eq-specializer class)))
190 ;;; internal to this file..
192 ;;; These functions are a pale imitation of their namesake. They accept
193 ;;; class objects or types where they should.
194 (defun *normalize-type (type)
196 (if (member (car type) '(not and or))
197 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
198 (if (null (cdr type))
199 (*normalize-type (car type))
202 (let ((class (find-class type nil)))
204 (let ((type (specializer-type class)))
205 (if (listp type) type `(,type)))
207 ((or (not (eq *boot-state* 'complete))
209 (specializer-type type))
211 (error "~S is not a type." type))))
213 ;;; internal to this file...
214 (defun convert-to-system-type (type)
216 ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
218 ((class class-eq) ; class-eq is impossible to do right
219 (sb-kernel:layout-class (class-wrapper (cadr type))))
221 (t (if (null (cdr type))
225 ;;; Writing the missing NOT and AND clauses will improve the quality
226 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
227 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
228 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
230 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
231 ;;; in the compiler. Could we share some of it here?
232 (defun *subtypep (type1 type2)
233 (if (equal type1 type2)
235 (if (eq *boot-state* 'early)
236 (values (eq type1 type2) t)
237 (let ((*in-precompute-effective-methods-p* t))
238 (declare (special *in-precompute-effective-methods-p*))
239 ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
240 ;; good name. It changes the way
241 ;; CLASS-APPLICABLE-USING-CLASS-P works.
242 (setq type1 (*normalize-type type1))
243 (setq type2 (*normalize-type type2))
246 (values nil nil)) ; XXX We should improve this.
248 (values nil nil)) ; XXX We should improve this.
249 ((eql wrapper-eq class-eq class)
250 (multiple-value-bind (app-p maybe-app-p)
251 (specializer-applicable-using-type-p type2 type1)
252 (values app-p (or app-p (not maybe-app-p)))))
254 (subtypep (convert-to-system-type type1)
255 (convert-to-system-type type2))))))))
257 (defvar *built-in-class-symbols* ())
258 (defvar *built-in-wrapper-symbols* ())
260 (defun get-built-in-class-symbol (class-name)
261 (or (cadr (assq class-name *built-in-class-symbols*))
262 (let ((symbol (intern (format nil
264 (symbol-name class-name))
266 (push (list class-name symbol) *built-in-class-symbols*)
269 (defun get-built-in-wrapper-symbol (class-name)
270 (or (cadr (assq class-name *built-in-wrapper-symbols*))
271 (let ((symbol (intern (format nil
272 "*THE-WRAPPER-OF-~A*"
273 (symbol-name class-name))
275 (push (list class-name symbol) *built-in-wrapper-symbols*)
278 (pushnew '%class *var-declarations*)
279 (pushnew '%variable-rebinding *var-declarations*)
281 (defun variable-class (var env)
282 (caddr (var-declaration 'class var env)))
284 (defvar *name->class->slotd-table* (make-hash-table))
286 ;;; This is used by combined methods to communicate the next methods
287 ;;; to the methods they call. This variable is captured by a lexical
288 ;;; variable of the methods to give it the proper lexical scope.
289 (defvar *next-methods* nil)
291 (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
294 (defvar *umi-complete-classes*)
295 (defvar *umi-reorder*)
297 (defvar *invalidate-discriminating-function-force-p* ())
298 (defvar *invalid-dfuns-on-stack* ())
300 (defvar *standard-method-combination*)
302 (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
304 (defmacro define-gf-predicate (predicate-name &rest classes)
306 (defmethod ,predicate-name ((x t)) nil)
307 ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
310 (defun make-class-predicate-name (name)
311 (intern (format nil "~A::~A class predicate"
312 (package-name (symbol-package name))
316 (defun plist-value (object name)
317 (getf (object-plist object) name))
319 (defun (setf plist-value) (new-value object name)
321 (setf (getf (object-plist object) name) new-value)
323 (remf (object-plist object) name)
326 ;;;; built-in classes
328 ;;; FIXME: This was the portable PCL way of setting up
329 ;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
330 ;;; entirely wasted motion, since it's immediately overwritten by a
331 ;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
332 ;;; we can't just delete it, since the fifth element from each entry
333 ;;; (a prototype of the class) is still in the final result. It would
334 ;;; be nice to clean this up so that the other, never-used stuff is
335 ;;; gone, perhaps finding a tidier way to represent examples of each
338 ;;; FIXME: This can probably be blown away after bootstrapping.
339 ;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
341 (defvar *built-in-classes*
342 ;; name supers subs cdr of cpl
344 '(;(t () (number sequence array character symbol) ())
345 (number (t) (complex float rational) (t))
346 (complex (number) () (number t)
348 (float (number) () (number t)
350 (rational (number) (integer ratio) (number t))
351 (integer (rational) () (rational number t)
353 (ratio (rational) () (rational number t)
356 (sequence (t) (list vector) (t))
357 (list (sequence) (cons null) (sequence t))
358 (cons (list) () (list sequence t)
361 (array (t) (vector) (t)
364 sequence) (string bit-vector) (array sequence t)
366 (string (vector) () (vector array sequence t)
368 (bit-vector (vector) () (vector array sequence t)
370 (character (t) () (t)
373 (symbol (t) (null) (t)
376 list) () (symbol list sequence t)
380 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
381 ;;; SB-PCL:*BUILT-IN-CLASSES*.
382 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
383 (defvar *built-in-classes*
384 (labels ((direct-supers (class)
385 (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
386 (if (typep class 'cl:built-in-class)
387 (sb-kernel:built-in-class-direct-superclasses class)
388 (let ((inherits (sb-kernel:layout-inherits
389 (sb-kernel:class-layout class))))
391 (list (svref inherits (1- (length inherits)))))))
393 (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
395 (let ((subs (sb-kernel:class-subclasses class)))
401 (when (member class (direct-supers sub))
404 (prototype (class-name)
405 (let ((assoc (assoc class-name
406 '((complex . #c(1 1))
422 ;; This is the default prototype value which was
423 ;; used, without explanation, by the CMU CL code
424 ;; we're derived from. Evidently it's safe in all
427 (mapcar (lambda (kernel-bic-entry)
428 (/noshow "setting up" kernel-bic-entry)
429 (let* ((name (car kernel-bic-entry))
430 (class (cl:find-class name)))
433 ,(mapcar #'cl:class-name (direct-supers class))
434 ,(mapcar #'cl:class-name (direct-subs class))
437 (cl:class-name (sb-kernel:layout-class x)))
439 (sb-kernel:layout-inherits
440 (sb-kernel:class-layout class))))
442 (remove-if (lambda (kernel-bic-entry)
443 (member (first kernel-bic-entry)
444 ;; I'm not sure why these are removed from
445 ;; the list, but that's what the original
446 ;; CMU CL code did. -- WHN 20000715
447 '(t sb-kernel:instance
448 sb-kernel:funcallable-instance
450 sb-kernel::*built-in-classes*))))
451 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
453 ;;;; the classes that define the kernel of the metabraid
456 (:metaclass built-in-class))
458 (defclass sb-kernel:instance (t) ()
459 (:metaclass built-in-class))
461 (defclass function (t) ()
462 (:metaclass built-in-class))
464 (defclass sb-kernel:funcallable-instance (function) ()
465 (:metaclass built-in-class))
467 (defclass stream (sb-kernel:instance) ()
468 (:metaclass built-in-class))
470 (defclass slot-object (t) ()
471 (:metaclass slot-class))
473 (defclass structure-object (slot-object sb-kernel:instance) ()
474 (:metaclass structure-class))
476 (defstruct (dead-beef-structure-object
477 (:constructor |STRUCTURE-OBJECT class constructor|)
480 (defclass std-object (slot-object) ()
481 (:metaclass std-class))
483 (defclass standard-object (std-object sb-kernel:instance) ())
485 (defclass funcallable-standard-object (std-object
486 sb-kernel:funcallable-instance)
488 (:metaclass funcallable-standard-class))
490 (defclass specializer (standard-object)
493 :reader specializer-type)))
495 (defclass definition-source-mixin (std-object)
497 :initform *load-truename*
498 :reader definition-source
499 :initarg :definition-source))
500 (:metaclass std-class))
502 (defclass plist-mixin (std-object)
505 :accessor object-plist))
506 (:metaclass std-class))
508 (defclass documentation-mixin (plist-mixin)
510 (:metaclass std-class))
512 (defclass dependent-update-mixin (plist-mixin)
514 (:metaclass std-class))
516 ;;; The class CLASS is a specified basic class. It is the common
517 ;;; superclass of any kind of class. That is, any class that can be a
518 ;;; metaclass must have the class CLASS in its class precedence list.
519 (defclass class (documentation-mixin
520 dependent-update-mixin
521 definition-source-mixin
526 :accessor class-name)
527 (class-eq-specializer
529 :reader class-eq-specializer)
532 :reader class-direct-superclasses)
533 ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
534 ;; CONDITION-CLASSes are lazily computed whenever the subclass info
535 ;; becomes available, i.e. when the PCL class is created.
538 :reader class-direct-subclasses)
540 :initform (cons nil nil))
543 :reader class-predicate-name)))
545 ;;; The class PCL-CLASS is an implementation-specific common
546 ;;; superclass of all specified subclasses of the class CLASS.
547 (defclass pcl-class (class)
548 ((class-precedence-list
549 :reader class-precedence-list)
552 :reader class-can-precede-list)
553 (incompatible-superclass-list
555 :accessor class-incompatible-superclass-list)
558 :reader class-wrapper)
561 :reader class-prototype)))
563 (defclass slot-class (pcl-class)
566 :accessor class-direct-slots)
569 :accessor class-slots)
572 :accessor class-initialize-info)))
574 ;;; The class STD-CLASS is an implementation-specific common
575 ;;; superclass of the classes STANDARD-CLASS and
576 ;;; FUNCALLABLE-STANDARD-CLASS.
577 (defclass std-class (slot-class)
580 (defclass standard-class (std-class)
583 (defclass funcallable-standard-class (std-class)
586 (defclass forward-referenced-class (pcl-class) ())
588 (defclass built-in-class (pcl-class) ())
590 (defclass structure-class (slot-class)
593 :accessor class-defstruct-form)
594 (defstruct-constructor
596 :accessor class-defstruct-constructor)
599 :initarg :from-defclass-p)))
601 (defclass specializer-with-object (specializer) ())
603 (defclass exact-class-specializer (specializer) ())
605 (defclass class-eq-specializer (exact-class-specializer
606 specializer-with-object)
607 ((object :initarg :class
608 :reader specializer-class
609 :reader specializer-object)))
611 (defclass class-prototype-specializer (specializer-with-object)
612 ((object :initarg :class
613 :reader specializer-class
614 :reader specializer-object)))
616 (defclass eql-specializer (exact-class-specializer specializer-with-object)
617 ((object :initarg :object :reader specializer-object
618 :reader eql-specializer-object)))
620 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
622 (defun intern-eql-specializer (object)
623 (or (gethash object *eql-specializer-table*)
624 (setf (gethash object *eql-specializer-table*)
625 (make-instance 'eql-specializer :object object))))
627 ;;;; slot definitions
629 (defclass slot-definition (standard-object)
633 :accessor slot-definition-name)
637 :accessor slot-definition-initform)
640 :initarg :initfunction
641 :accessor slot-definition-initfunction)
645 :accessor slot-definition-readers)
649 :accessor slot-definition-writers)
653 :accessor slot-definition-initargs)
657 :accessor slot-definition-type)
660 :initarg :documentation)
664 :accessor slot-definition-class)))
666 (defclass standard-slot-definition (slot-definition)
670 :accessor slot-definition-allocation)))
672 (defclass structure-slot-definition (slot-definition)
673 ((defstruct-accessor-symbol
675 :initarg :defstruct-accessor-symbol
676 :accessor slot-definition-defstruct-accessor-symbol)
677 (internal-reader-function
679 :initarg :internal-reader-function
680 :accessor slot-definition-internal-reader-function)
681 (internal-writer-function
683 :initarg :internal-writer-function
684 :accessor slot-definition-internal-writer-function)))
686 (defclass direct-slot-definition (slot-definition)
689 (defclass effective-slot-definition (slot-definition)
690 ((reader-function ; (lambda (object) ...)
691 :accessor slot-definition-reader-function)
692 (writer-function ; (lambda (new-value object) ...)
693 :accessor slot-definition-writer-function)
694 (boundp-function ; (lambda (object) ...)
695 :accessor slot-definition-boundp-function)
699 (defclass standard-direct-slot-definition (standard-slot-definition
700 direct-slot-definition)
703 (defclass standard-effective-slot-definition (standard-slot-definition
704 effective-slot-definition)
705 ((location ; nil, a fixnum, a cons: (slot-name . value)
707 :accessor slot-definition-location)))
709 (defclass structure-direct-slot-definition (structure-slot-definition
710 direct-slot-definition)
713 (defclass structure-effective-slot-definition (structure-slot-definition
714 effective-slot-definition)
717 (defclass method (standard-object) ())
719 (defclass standard-method (definition-source-mixin plist-mixin method)
722 :accessor method-generic-function)
725 ;;; :initarg :qualifiers
726 ;;; :reader method-qualifiers)
729 :initarg :specializers
730 :reader method-specializers)
733 :initarg :lambda-list
734 :reader method-lambda-list)
737 :initarg :function) ;no writer
740 :initarg :fast-function ;no writer
741 :reader method-fast-function)
744 ;;; :initarg :documentation
745 ;;; :reader method-documentation)
748 (defclass standard-accessor-method (standard-method)
749 ((slot-name :initform nil
751 :reader accessor-method-slot-name)
752 (slot-definition :initform nil
753 :initarg :slot-definition
754 :reader accessor-method-slot-definition)))
756 (defclass standard-reader-method (standard-accessor-method) ())
758 (defclass standard-writer-method (standard-accessor-method) ())
760 (defclass standard-boundp-method (standard-accessor-method) ())
762 (defclass generic-function (dependent-update-mixin
763 definition-source-mixin
765 funcallable-standard-object)
766 (;; We need to make a distinction between the methods initially set
767 ;; up by :METHOD options to DEFGENERIC and the ones set up later by
768 ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
769 ;; an already-DEFGENERICed function clears the methods set by the
770 ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
771 ;; this distinction seems a little kludgy, but it has the positive
772 ;; effect of making it so that loading a file a.lisp containing
773 ;; DEFGENERIC, then loading a second file b.lisp containing
774 ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
775 ;; tends to leave the generic function in a state consistent with
776 ;; the most-recently-loaded state of a.lisp and b.lisp.)
779 :accessor generic-function-initial-methods))
780 (:metaclass funcallable-standard-class))
782 (defclass standard-generic-function (generic-function)
786 :accessor generic-function-name)
789 :accessor generic-function-methods
792 :initarg :method-class
793 :accessor generic-function-method-class)
795 :initarg :method-combination
796 :accessor generic-function-method-combination)
798 :initform (make-arg-info)
802 :accessor gf-dfun-state))
803 (:metaclass funcallable-standard-class)
804 (:default-initargs :method-class *the-class-standard-method*
805 :method-combination *standard-method-combination*))
807 (defclass method-combination (standard-object) ())
809 (defclass standard-method-combination (definition-source-mixin
812 :reader method-combination-type
815 :reader method-combination-documentation
816 :initarg :documentation)
818 :reader method-combination-options
821 (defparameter *early-class-predicates*
822 '((specializer specializerp)
823 (exact-class-specializer exact-class-specializer-p)
824 (class-eq-specializer class-eq-specializer-p)
825 (eql-specializer eql-specializer-p)
827 (slot-class slot-class-p)
828 (std-class std-class-p)
829 (standard-class standard-class-p)
830 (funcallable-standard-class funcallable-standard-class-p)
831 (structure-class structure-class-p)
832 (forward-referenced-class forward-referenced-class-p)
834 (standard-method standard-method-p)
835 (standard-accessor-method standard-accessor-method-p)
836 (standard-reader-method standard-reader-method-p)
837 (standard-writer-method standard-writer-method-p)
838 (standard-boundp-method standard-boundp-method-p)
839 (generic-function generic-function-p)
840 (standard-generic-function standard-generic-function-p)
841 (method-combination method-combination-p)))