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 *name-
>class-
>slotd-table
* (make-hash-table))
205 (defvar *standard-method-combination
*)
207 (defun make-class-predicate-name (name)
208 (list 'class-predicate name
))
210 (defun plist-value (object name
)
211 (getf (object-plist object
) name
))
213 (defun (setf plist-value
) (new-value object name
)
215 (setf (getf (object-plist object
) name
) new-value
)
217 (remf (object-plist object
) name
)
220 ;;;; built-in classes
222 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
223 ;;; SB-PCL:*BUILT-IN-CLASSES*.
224 (/show
"about to set up SB-PCL::*BUILT-IN-CLASSES*")
225 (defvar *built-in-classes
*
226 (labels ((direct-supers (class)
227 (/noshow
"entering DIRECT-SUPERS" (classoid-name class
))
228 (if (typep class
'built-in-classoid
)
229 (built-in-classoid-direct-superclasses class
)
230 (let ((inherits (layout-inherits
231 (classoid-layout class
))))
233 (list (svref inherits
(1- (length inherits
)))))))
235 (/noshow
"entering DIRECT-SUBS" (classoid-name class
))
237 (let ((subs (classoid-subclasses class
)))
243 (when (member class
(direct-supers sub
))
246 (mapcar (lambda (kernel-bic-entry)
247 (/noshow
"setting up" kernel-bic-entry
)
248 (let* ((name (car kernel-bic-entry
))
249 (class (find-classoid name
))
251 (getf (cdr kernel-bic-entry
) :prototype-form
)))
254 ,(mapcar #'classoid-name
(direct-supers class
))
255 ,(mapcar #'classoid-name
(direct-subs class
))
259 (layout-classoid x
)))
262 (classoid-layout class
))))
264 (eval prototype-form
)
265 ;; This is the default prototype value which
266 ;; was used, without explanation, by the CMU CL
267 ;; code we're derived from. Evidently it's safe
268 ;; in all relevant cases.
270 (remove-if (lambda (kernel-bic-entry)
271 (member (first kernel-bic-entry
)
272 ;; I'm not sure why these are removed from
273 ;; the list, but that's what the original
274 ;; CMU CL code did. -- WHN 20000715
276 file-stream string-stream
)))
277 sb-kernel
::*built-in-classes
*))))
278 (/noshow
"done setting up SB-PCL::*BUILT-IN-CLASSES*")
280 ;;;; the classes that define the kernel of the metabraid
283 (:metaclass built-in-class
))
285 (defclass function
(t) ()
286 (:metaclass built-in-class
))
288 (defclass stream
(t) ()
289 (:metaclass built-in-class
))
291 (defclass file-stream
(stream) ()
292 (:metaclass built-in-class
))
294 (defclass string-stream
(stream) ()
295 (:metaclass built-in-class
))
297 (defclass slot-object
(t) ()
298 (:metaclass slot-class
))
300 (defclass condition
(slot-object) ()
301 (:metaclass condition-class
))
303 (defclass structure-object
(slot-object) ()
304 (:metaclass structure-class
))
306 (defstruct (dead-beef-structure-object
307 (:constructor |STRUCTURE-OBJECT class constructor|
)
310 (defclass standard-object
(slot-object) ())
312 (defclass funcallable-standard-object
(standard-object function
)
314 (:metaclass funcallable-standard-class
))
316 (defclass metaobject
(standard-object) ())
318 (defclass generic-function
(dependent-update-mixin
319 definition-source-mixin
321 funcallable-standard-object
)
324 :initarg
:documentation
)
325 ;; We need to make a distinction between the methods initially set
326 ;; up by :METHOD options to DEFGENERIC and the ones set up later by
327 ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
328 ;; an already-DEFGENERICed function clears the methods set by the
329 ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
330 ;; this distinction seems a little kludgy, but it has the positive
331 ;; effect of making it so that loading a file a.lisp containing
332 ;; DEFGENERIC, then loading a second file b.lisp containing
333 ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
334 ;; tends to leave the generic function in a state consistent with
335 ;; the most-recently-loaded state of a.lisp and b.lisp.)
338 :accessor generic-function-initial-methods
))
339 (:metaclass funcallable-standard-class
))
341 (defclass standard-generic-function
(generic-function)
345 :reader generic-function-name
)
348 :accessor generic-function-methods
351 :initarg
:method-class
352 :accessor generic-function-method-class
)
354 :initarg
:method-combination
355 :accessor generic-function-method-combination
)
357 ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
358 ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning
359 ;; might be appropriate).
360 :initarg
:declarations
363 :accessor generic-function-declarations
)
365 :initform
(make-arg-info)
369 :accessor gf-dfun-state
))
370 (:metaclass funcallable-standard-class
)
371 (:default-initargs
:method-class
*the-class-standard-method
*
372 :method-combination
*standard-method-combination
*))
374 (defclass method
(metaobject) ())
376 (defclass standard-method
(definition-source-mixin plist-mixin method
)
379 :accessor method-generic-function
)
382 ;;; :initarg :qualifiers
383 ;;; :reader method-qualifiers)
386 :initarg
:specializers
387 :reader method-specializers
)
390 :initarg
:lambda-list
391 :reader method-lambda-list
)
394 :initarg
:function
) ;no writer
397 :initarg
:fast-function
;no writer
398 :reader method-fast-function
)
401 :initarg
:documentation
)))
403 (defclass standard-accessor-method
(standard-method)
404 ((slot-name :initform nil
406 :reader accessor-method-slot-name
)
407 (slot-definition :initform nil
408 :initarg
:slot-definition
409 :reader accessor-method-slot-definition
)))
411 (defclass standard-reader-method
(standard-accessor-method) ())
412 (defclass standard-writer-method
(standard-accessor-method) ())
413 ;;; an extension, apparently.
414 (defclass standard-boundp-method
(standard-accessor-method) ())
416 (defclass method-combination
(metaobject)
418 :reader method-combination-documentation
420 :initarg
:documentation
)))
422 (defclass standard-method-combination
(definition-source-mixin
425 :reader method-combination-type
428 :reader method-combination-options
431 (defclass long-method-combination
(standard-method-combination)
434 :reader long-method-combination-function
)
436 :initarg
:args-lambda-list
437 :reader long-method-combination-args-lambda-list
)))
439 (defclass slot-definition
(metaobject)
443 :accessor slot-definition-name
)
447 :accessor slot-definition-initform
)
450 :initarg
:initfunction
451 :accessor slot-definition-initfunction
)
455 :accessor slot-definition-readers
)
459 :accessor slot-definition-writers
)
463 :accessor slot-definition-initargs
)
467 :accessor slot-definition-type
)
470 :initarg
:documentation
471 ;; FIXME: should we export this, as an extension?
472 :accessor %slot-definition-documentation
)
476 :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 ((type :initform nil
:reader specializer-type
)))
554 (defclass specializer-with-object
(specializer) ())
556 (defclass exact-class-specializer
(specializer) ())
558 (defclass class-eq-specializer
(exact-class-specializer
559 specializer-with-object
)
560 ((object :initarg
:class
561 :reader specializer-class
562 :reader specializer-object
)))
564 (defclass class-prototype-specializer
(specializer-with-object)
565 ((object :initarg
:class
566 :reader specializer-class
567 :reader specializer-object
)))
569 (defclass eql-specializer
(exact-class-specializer specializer-with-object
)
570 ((object :initarg
:object
:reader specializer-object
571 :reader eql-specializer-object
)))
573 (defvar *eql-specializer-table
* (make-hash-table :test
'eql
))
575 (defun intern-eql-specializer (object)
576 (or (gethash object
*eql-specializer-table
*)
577 (setf (gethash object
*eql-specializer-table
*)
578 (make-instance 'eql-specializer
:object object
))))
580 (defclass class
(dependent-update-mixin
581 definition-source-mixin
587 (class-eq-specializer
589 :reader class-eq-specializer
)
592 :reader class-direct-superclasses
)
593 ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
594 ;; CONDITION-CLASSes are lazily computed whenever the subclass info
595 ;; becomes available, i.e. when the PCL class is created.
598 :reader class-direct-subclasses
)
600 :initform
(cons nil nil
))
603 :reader class-predicate-name
)
606 :initarg
:documentation
)
609 :reader class-finalized-p
)))
611 (def!method make-load-form
((class class
) &optional env
)
612 ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
613 ;; doesn't matter while all our environments are the same...
614 (declare (ignore env
))
615 (let ((name (class-name class
)))
616 (unless (and name
(eq (find-class name nil
) class
))
617 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
619 `(find-class ',name
)))
621 ;;; The class PCL-CLASS is an implementation-specific common
622 ;;; superclass of all specified subclasses of the class CLASS.
623 (defclass pcl-class
(class)
624 ((class-precedence-list
625 :reader class-precedence-list
)
626 ;; KLUDGE: see note in CPL-OR-NIL
628 :reader cpl-available-p
632 :reader class-can-precede-list
)
633 (incompatible-superclass-list
635 :accessor class-incompatible-superclass-list
)
638 :reader class-wrapper
)
641 :reader class-prototype
)))
643 (defclass slot-class
(pcl-class)
646 :accessor class-direct-slots
)
649 :accessor class-slots
)))
651 ;;; The class STD-CLASS is an implementation-specific common
652 ;;; superclass of the classes STANDARD-CLASS and
653 ;;; FUNCALLABLE-STANDARD-CLASS.
654 (defclass std-class
(slot-class)
657 (defclass standard-class
(std-class)
660 (defclass funcallable-standard-class
(std-class)
663 (defclass forward-referenced-class
(pcl-class) ())
665 (defclass built-in-class
(pcl-class) ())
667 (defclass condition-class
(slot-class) ())
669 (defclass structure-class
(slot-class)
672 :accessor class-defstruct-form
)
673 (defstruct-constructor
675 :accessor class-defstruct-constructor
)
678 :initarg
:from-defclass-p
)))
680 (defclass definition-source-mixin
(standard-object)
683 :reader definition-source
684 :initarg
:definition-source
)))
686 (defclass plist-mixin
(standard-object)
687 ((plist :initform
() :accessor object-plist
)))
689 (defclass dependent-update-mixin
(plist-mixin) ())
691 (defparameter *early-class-predicates
*
692 '((specializer specializerp
)
693 (exact-class-specializer exact-class-specializer-p
)
694 (class-eq-specializer class-eq-specializer-p
)
695 (eql-specializer eql-specializer-p
)
697 (slot-class slot-class-p
)
698 (std-class std-class-p
)
699 (standard-class standard-class-p
)
700 (funcallable-standard-class funcallable-standard-class-p
)
701 (condition-class condition-class-p
)
702 (structure-class structure-class-p
)
703 (forward-referenced-class forward-referenced-class-p
)
705 (standard-method standard-method-p
)
706 (standard-accessor-method standard-accessor-method-p
)
707 (standard-reader-method standard-reader-method-p
)
708 (standard-writer-method standard-writer-method-p
)
709 (standard-boundp-method standard-boundp-method-p
)
710 (generic-function generic-function-p
)
711 (standard-generic-function standard-generic-function-p
)
712 (method-combination method-combination-p
)
713 (long-method-combination long-method-combination-p
)))