;;; build, of course, but they might happen if someone is experimenting
;;; and debugging, and it's probably worth complaining if they do,
;;; so we've left 'em in.)
-(when (eq *boot-state* 'complete)
+(when (eq **boot-state** 'complete)
(error "Trying to load (or compile) PCL in an environment in which it~%~
- has already been loaded. This doesn't work, you will have to~%~
- get a fresh lisp (reboot) and then load PCL."))
-(when *boot-state*
+ has already been loaded. This doesn't work, you will have to~%~
+ get a fresh lisp (reboot) and then load PCL."))
+(when **boot-state**
(cerror "Try loading (or compiling) PCL anyways."
- "Trying to load (or compile) PCL in an environment in which it~%~
- has already been partially loaded. This may not work, you may~%~
- need to get a fresh lisp (reboot) and then load PCL."))
+ "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been partially loaded. This may not work, you may~%~
+ need to get a fresh lisp (reboot) and then load PCL."))
\f
-;;; comments from CMU CL version of PCL:
-;;; This is like fdefinition on the Lispm. If Common Lisp had
-;;; something like function specs I wouldn't need this. On the other
-;;; hand, I don't like the way this really works so maybe function
-;;; specs aren't really right either?
-;;; I also don't understand the real implications of a Lisp-1 on this
-;;; sort of thing. Certainly some of the lossage in all of this is
-;;; because these SPECs name global definitions.
-;;; Note that this implementation is set up so that an implementation
-;;; which has a 'real' function spec mechanism can use that instead
-;;; and in that way get rid of setf generic function names.
-(defmacro parse-gspec (spec
- (non-setf-var . non-setf-case))
- `(let ((,non-setf-var ,spec)) ,@non-setf-case))
-
-;;; If symbol names a function which is traced, return the untraced
-;;; definition. This lets us get at the generic function object even
-;;; when it is traced.
-(defun unencapsulated-fdefinition (symbol)
- (fdefinition symbol))
-
-;;; If symbol names a function which is traced, redefine the `real'
-;;; definition without affecting the trace.
-(defun fdefine-carefully (name new-definition)
- (progn
- (sb-c::note-name-defined name :function)
- new-definition)
- (setf (fdefinition name) new-definition))
-
-(defun gboundp (spec)
- (parse-gspec spec
- (name (fboundp name))))
-
-(defun gmakunbound (spec)
- (parse-gspec spec
- (name (fmakunbound name))))
-
+#-sb-fluid (declaim (inline gdefinition))
(defun gdefinition (spec)
- (parse-gspec spec
- (name (unencapsulated-fdefinition name))))
+ ;; This is null layer right now, but once FDEFINITION stops bypasssing
+ ;; fwrappers/encapsulations we can do that here.
+ (fdefinition spec))
(defun (setf gdefinition) (new-value spec)
- (parse-gspec spec
- (name (fdefine-carefully name new-value))))
-\f
-(declaim (special *the-class-t*
- *the-class-vector* *the-class-symbol*
- *the-class-string* *the-class-sequence*
- *the-class-rational* *the-class-ratio*
- *the-class-number* *the-class-null* *the-class-list*
- *the-class-integer* *the-class-float* *the-class-cons*
- *the-class-complex* *the-class-character*
- *the-class-bit-vector* *the-class-array*
- *the-class-stream*
-
- *the-class-slot-object*
- *the-class-structure-object*
- *the-class-std-object*
- *the-class-standard-object*
- *the-class-funcallable-standard-object*
- *the-class-class*
- *the-class-generic-function*
- *the-class-built-in-class*
- *the-class-slot-class*
- *the-class-structure-class*
- *the-class-std-class*
- *the-class-standard-class*
- *the-class-funcallable-standard-class*
- *the-class-method*
- *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*
- *the-class-standard-generic-function*
- *the-class-standard-effective-slot-definition*
-
- *the-eslotd-standard-class-slots*
- *the-eslotd-funcallable-standard-class-slots*))
-
-(declaim (special *the-wrapper-of-t*
- *the-wrapper-of-vector* *the-wrapper-of-symbol*
- *the-wrapper-of-string* *the-wrapper-of-sequence*
- *the-wrapper-of-rational* *the-wrapper-of-ratio*
- *the-wrapper-of-number* *the-wrapper-of-null*
- *the-wrapper-of-list* *the-wrapper-of-integer*
- *the-wrapper-of-float* *the-wrapper-of-cons*
- *the-wrapper-of-complex* *the-wrapper-of-character*
- *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
+ ;; This is almost a null layer right now, but once (SETF
+ ;; FDEFINITION) stops bypasssing fwrappers/encapsulations we can do
+ ;; that here.
+ (sb-c::note-name-defined spec :function) ; FIXME: do we need this? Why?
+ (setf (fdefinition spec) new-value))
\f
;;;; type specifier hackery
(defun coerce-to-class (class &optional make-forward-referenced-class-p)
(if (symbolp class)
(or (find-class class (not make-forward-referenced-class-p))
- (ensure-class class))
+ (ensure-class class))
class))
;;; interface
(defun specializer-from-type (type &aux args)
+ (when (symbolp type)
+ (return-from specializer-from-type (find-class type)))
(when (consp type)
(setq args (cdr type) type (car type)))
(cond ((symbolp type)
- (or (and (null args) (find-class type))
- (ecase type
- (class (coerce-to-class (car args)))
- (prototype (make-instance 'class-prototype-specializer
- :object (coerce-to-class (car args))))
- (class-eq (class-eq-specializer (coerce-to-class (car args))))
- (eql (intern-eql-specializer (car args))))))
- ((and (null args) (typep type 'cl:class))
- (or (sb-kernel:class-pcl-class type)
- (find-structure-class (cl:class-name type))))
- ((specializerp type) type)))
+ (or (ecase type
+ (class (coerce-to-class (car args)))
+ (prototype (make-instance 'class-prototype-specializer
+ :object (coerce-to-class (car args))))
+ (class-eq (class-eq-specializer (coerce-to-class (car args))))
+ (eql (intern-eql-specializer (car args))))))
+ ;; FIXME: do we still need this?
+ ((and (null args) (typep type 'classoid))
+ (or (classoid-pcl-class type)
+ (ensure-non-standard-class (classoid-name type) type)))
+ ((specializerp type) type)))
;;; interface
(defun type-from-specializer (specl)
(cond ((eq specl t)
- t)
- ((consp specl)
- (unless (member (car specl) '(class prototype class-eq eql))
- (error "~S is not a legal specializer type." specl))
- specl)
- ((progn
- (when (symbolp specl)
- ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
- (setq specl (find-class specl)))
- (or (not (eq *boot-state* 'complete))
- (specializerp specl)))
- (specializer-type specl))
- (t
- (error "~S is neither a type nor a specializer." specl))))
+ t)
+ ((consp specl)
+ (unless (member (car specl) '(class prototype class-eq eql))
+ (error "~S is not a legal specializer type." specl))
+ specl)
+ ((progn
+ (when (symbolp specl)
+ ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
+ (setq specl (find-class specl)))
+ (or (not (eq **boot-state** 'complete))
+ (specializerp specl)))
+ (specializer-type specl))
+ (t
+ (error "~S is neither a type nor a specializer." specl))))
(defun type-class (type)
(declare (special *the-class-t*))
(setq type (type-from-specializer type))
(if (atom type)
(if (eq type t)
- *the-class-t*
- (error "bad argument to TYPE-CLASS"))
+ *the-class-t*
+ (error "bad argument to TYPE-CLASS"))
(case (car type)
- (eql (class-of (cadr type)))
- (prototype (class-of (cadr type))) ;?
- (class-eq (cadr type))
- (class (cadr type)))))
+ (eql (class-of (cadr type)))
+ (prototype (class-of (cadr type))) ;?
+ (class-eq (cadr type))
+ (class (cadr type)))))
(defun class-eq-type (class)
(specializer-type (class-eq-specializer class)))
;;; class objects or types where they should.
(defun *normalize-type (type)
(cond ((consp type)
- (if (member (car type) '(not and or))
- `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
- (if (null (cdr type))
- (*normalize-type (car type))
- type)))
- ((symbolp type)
- (let ((class (find-class type nil)))
- (if class
- (let ((type (specializer-type class)))
- (if (listp type) type `(,type)))
- `(,type))))
- ((or (not (eq *boot-state* 'complete))
- (specializerp type))
- (specializer-type type))
- (t
- (error "~S is not a type." type))))
+ (if (member (car type) '(not and or))
+ `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
+ (if (null (cdr type))
+ (*normalize-type (car type))
+ type)))
+ ((symbolp type)
+ (let ((class (find-class type nil)))
+ (if class
+ (let ((type (specializer-type class)))
+ (if (listp type) type `(,type)))
+ `(,type))))
+ ((or (not (eq **boot-state** 'complete))
+ (specializerp type))
+ (specializer-type type))
+ (t
+ (error "~S is not a type." type))))
;;; internal to this file...
(defun convert-to-system-type (type)
(case (car type)
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
- (cdr type))))
+ (cdr type))))
((class class-eq) ; class-eq is impossible to do right
- (sb-kernel:layout-class (class-wrapper (cadr type))))
+ (layout-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
- (car type)
- type))))
+ (car type)
+ type))))
;;; Writing the missing NOT and AND clauses will improve the quality
;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
;;;
;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
-;;; in the compiler. Could we share some of it here?
+;;; in the compiler. Could we share some of it here?
+(defvar *in-*subtypep* nil)
+
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
- (if (eq *boot-state* 'early)
- (values (eq type1 type2) t)
- (let ((*in-precompute-effective-methods-p* t))
- (declare (special *in-precompute-effective-methods-p*))
- ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
- ;; good name. It changes the way
- ;; CLASS-APPLICABLE-USING-CLASS-P works.
- (setq type1 (*normalize-type type1))
- (setq type2 (*normalize-type type2))
- (case (car type2)
- (not
- (values nil nil)) ; XXX We should improve this.
- (and
- (values nil nil)) ; XXX We should improve this.
- ((eql wrapper-eq class-eq class)
- (multiple-value-bind (app-p maybe-app-p)
- (specializer-applicable-using-type-p type2 type1)
- (values app-p (or app-p (not maybe-app-p)))))
- (t
- (subtypep (convert-to-system-type type1)
- (convert-to-system-type type2))))))))
+ (if (eq **boot-state** 'early)
+ (values (eq type1 type2) t)
+ (let ((*in-*subtypep* t))
+ (setq type1 (*normalize-type type1))
+ (setq type2 (*normalize-type type2))
+ (case (car type2)
+ (not
+ (values nil nil)) ; XXX We should improve this.
+ (and
+ (values nil nil)) ; XXX We should improve this.
+ ((eql wrapper-eq class-eq class)
+ (multiple-value-bind (app-p maybe-app-p)
+ (specializer-applicable-using-type-p type2 type1)
+ (values app-p (or app-p (not maybe-app-p)))))
+ (t
+ (subtypep (convert-to-system-type type1)
+ (convert-to-system-type type2))))))))
\f
(defvar *built-in-class-symbols* ())
(defvar *built-in-wrapper-symbols* ())
(defun get-built-in-class-symbol (class-name)
(or (cadr (assq class-name *built-in-class-symbols*))
- (let ((symbol (intern (format nil
- "*THE-CLASS-~A*"
- (symbol-name class-name))
- *pcl-package*)))
- (push (list class-name symbol) *built-in-class-symbols*)
- symbol)))
+ (let ((symbol (make-class-symbol class-name)))
+ (push (list class-name symbol) *built-in-class-symbols*)
+ symbol)))
(defun get-built-in-wrapper-symbol (class-name)
(or (cadr (assq class-name *built-in-wrapper-symbols*))
- (let ((symbol (intern (format nil
- "*THE-WRAPPER-OF-~A*"
- (symbol-name class-name))
- *pcl-package*)))
- (push (list class-name symbol) *built-in-wrapper-symbols*)
- symbol)))
+ (let ((symbol (make-wrapper-symbol class-name)))
+ (push (list class-name symbol) *built-in-wrapper-symbols*)
+ symbol)))
\f
-(pushnew '%class *var-declarations*)
-(pushnew '%variable-rebinding *var-declarations*)
-
-(defun variable-class (var env)
- (caddr (var-declaration 'class var env)))
-
-(defvar *name->class->slotd-table* (make-hash-table))
-
-;;; This is used by combined methods to communicate the next methods
-;;; to the methods they call. This variable is captured by a lexical
-;;; variable of the methods to give it the proper lexical scope.
-(defvar *next-methods* nil)
-
-(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
-
-(defvar *umi-gfs*)
-(defvar *umi-complete-classes*)
-(defvar *umi-reorder*)
-
-(defvar *invalidate-discriminating-function-force-p* ())
-(defvar *invalid-dfuns-on-stack* ())
-
(defvar *standard-method-combination*)
-
-(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
\f
-(defmacro define-gf-predicate (predicate-name &rest classes)
- `(progn
- (defmethod ,predicate-name ((x t)) nil)
- ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
- classes)))
-
-(defun make-class-predicate-name (name)
- (intern (format nil "~A::~A class predicate"
- (package-name (symbol-package name))
- name)
- *pcl-package*))
-
(defun plist-value (object name)
(getf (object-plist object) name))
(if new-value
(setf (getf (object-plist object) name) new-value)
(progn
- (remf (object-plist object) name)
- nil)))
+ (remf (object-plist object) name)
+ nil)))
\f
;;;; built-in classes
-;;; FIXME: This was the portable PCL way of setting up
-;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
-;;; entirely wasted motion, since it's immediately overwritten by a
-;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
-;;; we can't just delete it, since the fifth element from each entry
-;;; (a prototype of the class) is still in the final result. It would
-;;; be nice to clean this up so that the other, never-used stuff is
-;;; gone, perhaps finding a tidier way to represent examples of each
-;;; class, too.
-;;;
-;;; FIXME: This can probably be blown away after bootstrapping.
-;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
-#|
-(defvar *built-in-classes*
- ;; name supers subs cdr of cpl
- ;; prototype
- '(;(t () (number sequence array character symbol) ())
- (number (t) (complex float rational) (t))
- (complex (number) () (number t)
- #c(1 1))
- (float (number) () (number t)
- 1.0)
- (rational (number) (integer ratio) (number t))
- (integer (rational) () (rational number t)
- 1)
- (ratio (rational) () (rational number t)
- 1/2)
-
- (sequence (t) (list vector) (t))
- (list (sequence) (cons null) (sequence t))
- (cons (list) () (list sequence t)
- (nil))
-
- (array (t) (vector) (t)
- #2A((nil)))
- (vector (array
- sequence) (string bit-vector) (array sequence t)
- #())
- (string (vector) () (vector array sequence t)
- "")
- (bit-vector (vector) () (vector array sequence t)
- #*1)
- (character (t) () (t)
- #\c)
-
- (symbol (t) (null) (t)
- symbol)
- (null (symbol
- list) () (symbol list sequence t)
- nil)))
-|#
-
;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
;;; SB-PCL:*BUILT-IN-CLASSES*.
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
- (if (typep class 'cl:built-in-class)
- (sb-kernel:built-in-class-direct-superclasses class)
- (let ((inherits (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
- (/noshow inherits)
- (list (svref inherits (1- (length inherits)))))))
- (direct-subs (class)
- (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
- (collect ((res))
- (let ((subs (sb-kernel:class-subclasses class)))
- (/noshow subs)
- (when subs
- (dohash (sub v subs)
- (declare (ignore v))
- (/noshow sub)
- (when (member class (direct-supers sub))
- (res sub)))))
- (res)))
- (prototype (class-name)
- (let ((assoc (assoc class-name
- '((complex . #c(1 1))
- (float . 1.0)
- (integer . 1)
- (ratio . 1/2)
- (sequence . nil)
- (list . nil)
- (cons . (nil))
- (array . #2a((nil)))
- (vector . #())
- (string . "")
- (bit-vector . #*1)
- (character . #\c)
- (symbol . symbol)
- (null . nil)))))
- (if assoc
- (cdr assoc)
- ;; This is the default prototype value which was
- ;; used, without explanation, by the CMU CL code
- ;; we're derived from. Evidently it's safe in all
- ;; relevant cases.
- 42))))
+ (/noshow "entering DIRECT-SUPERS" (classoid-name class))
+ (if (typep class 'built-in-classoid)
+ (built-in-classoid-direct-superclasses class)
+ (let ((inherits (layout-inherits
+ (classoid-layout class))))
+ (/noshow inherits)
+ (list (svref inherits (1- (length inherits)))))))
+ (direct-subs (class)
+ (/noshow "entering DIRECT-SUBS" (classoid-name class))
+ (collect ((res))
+ (let ((subs (classoid-subclasses class)))
+ (/noshow subs)
+ (when subs
+ (dohash ((sub v) subs)
+ (declare (ignore v))
+ (/noshow sub)
+ (when (member class (direct-supers sub) :test #'eq)
+ (res sub)))))
+ (res))))
(mapcar (lambda (kernel-bic-entry)
- (/noshow "setting up" kernel-bic-entry)
- (let* ((name (car kernel-bic-entry))
- (class (cl:find-class name)))
- (/noshow name class)
- `(,name
- ,(mapcar #'cl:class-name (direct-supers class))
- ,(mapcar #'cl:class-name (direct-subs class))
- ,(map 'list
- (lambda (x)
- (cl:class-name (sb-kernel:layout-class x)))
- (reverse
- (sb-kernel:layout-inherits
- (sb-kernel:class-layout class))))
- ,(prototype name))))
- (remove-if (lambda (kernel-bic-entry)
- (member (first kernel-bic-entry)
- ;; I'm not sure why these are removed from
- ;; the list, but that's what the original
- ;; CMU CL code did. -- WHN 20000715
- '(t sb-kernel:instance
- sb-kernel:funcallable-instance
- function stream)))
- sb-kernel::*built-in-classes*))))
+ (/noshow "setting up" kernel-bic-entry)
+ (let* ((name (car kernel-bic-entry))
+ (class (find-classoid name))
+ (prototype-form
+ (getf (cdr kernel-bic-entry) :prototype-form)))
+ (/noshow name class)
+ `(,name
+ ,(mapcar #'classoid-name (direct-supers class))
+ ,(mapcar #'classoid-name (direct-subs class))
+ ,(map 'list
+ (lambda (x)
+ (classoid-name
+ (layout-classoid x)))
+ (reverse
+ (layout-inherits
+ (classoid-layout class))))
+ ,(if prototype-form
+ (eval prototype-form)
+ ;; This is the default prototype value which
+ ;; was used, without explanation, by the CMU CL
+ ;; code we're derived from. Evidently it's safe
+ ;; in all relevant cases.
+ 42))))
+ (remove-if (lambda (kernel-bic-entry)
+ (member (first kernel-bic-entry)
+ ;; I'm not sure why these are removed from
+ ;; the list, but that's what the original
+ ;; CMU CL code did. -- WHN 20000715
+ '(t function stream
+ file-stream string-stream)))
+ sb-kernel::*built-in-classes*))))
(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
(defclass t () ()
(:metaclass built-in-class))
-(defclass sb-kernel:instance (t) ()
+(defclass function (t) ()
(:metaclass built-in-class))
-(defclass function (t) ()
+(defclass stream (t) ()
(:metaclass built-in-class))
-(defclass sb-kernel:funcallable-instance (function) ()
+(defclass file-stream (stream) ()
(:metaclass built-in-class))
-(defclass stream (sb-kernel:instance) ()
+(defclass string-stream (stream) ()
(:metaclass built-in-class))
(defclass slot-object (t) ()
(:metaclass slot-class))
-(defclass structure-object (slot-object sb-kernel:instance) ()
+(defclass condition (slot-object) ()
+ (:metaclass condition-class))
+
+(defclass structure-object (slot-object) ()
(:metaclass structure-class))
(defstruct (dead-beef-structure-object
- (:constructor |STRUCTURE-OBJECT class constructor|)
- (:copier nil)))
-
-(defclass std-object (slot-object) ()
- (:metaclass std-class))
+ (:constructor |STRUCTURE-OBJECT class constructor|)
+ (:copier nil)))
-(defclass standard-object (std-object sb-kernel:instance) ())
+(defclass standard-object (slot-object) ())
-(defclass funcallable-standard-object (std-object
- sb-kernel:funcallable-instance)
+(defclass funcallable-standard-object (function standard-object)
()
(:metaclass funcallable-standard-class))
-(defclass specializer (standard-object)
- ((type
- :initform nil
- :reader specializer-type)))
-
-(defclass definition-source-mixin (std-object)
- ((source
- :initform *load-truename*
- :reader definition-source
- :initarg :definition-source))
- (:metaclass std-class))
-
-(defclass plist-mixin (std-object)
- ((plist
- :initform ()
- :accessor object-plist))
- (:metaclass std-class))
+(defclass metaobject (standard-object) ())
-(defclass documentation-mixin (plist-mixin)
- ()
- (:metaclass std-class))
+(defclass generic-function (dependent-update-mixin
+ definition-source-mixin
+ metaobject
+ funcallable-standard-object)
+ ((%documentation :initform nil :initarg :documentation)
+ ;; We need to make a distinction between the methods initially set
+ ;; up by :METHOD options to DEFGENERIC and the ones set up later by
+ ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
+ ;; an already-DEFGENERICed function clears the methods set by the
+ ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
+ ;; this distinction seems a little kludgy, but it has the positive
+ ;; effect of making it so that loading a file a.lisp containing
+ ;; DEFGENERIC, then loading a second file b.lisp containing
+ ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
+ ;; tends to leave the generic function in a state consistent with
+ ;; the most-recently-loaded state of a.lisp and b.lisp.)
+ (initial-methods :initform () :accessor generic-function-initial-methods)
+ (encapsulations :initform () :accessor generic-function-encapsulations))
+ (:metaclass funcallable-standard-class))
-(defclass dependent-update-mixin (plist-mixin)
- ()
- (:metaclass std-class))
-
-;;; The class CLASS is a specified basic class. It is the common
-;;; superclass of any kind of class. That is, any class that can be a
-;;; metaclass must have the class CLASS in its class precedence list.
-(defclass class (documentation-mixin
- dependent-update-mixin
- definition-source-mixin
- specializer)
+(defclass standard-generic-function (generic-function)
((name
:initform nil
- :initarg :name
- :accessor class-name)
- (class-eq-specializer
- :initform nil
- :reader class-eq-specializer)
- (direct-superclasses
- :initform ()
- :reader class-direct-superclasses)
- ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
- ;; CONDITION-CLASSes are lazily computed whenever the subclass info
- ;; becomes available, i.e. when the PCL class is created.
- (direct-subclasses
- :initform ()
- :reader class-direct-subclasses)
- (direct-methods
- :initform (cons nil nil))
- (predicate-name
- :initform nil
- :reader class-predicate-name)))
-
-;;; The class PCL-CLASS is an implementation-specific common
-;;; superclass of all specified subclasses of the class CLASS.
-(defclass pcl-class (class)
- ((class-precedence-list
- :reader class-precedence-list)
- (can-precede-list
- :initform ()
- :reader class-can-precede-list)
- (incompatible-superclass-list
+ :initarg :name
+ :reader generic-function-name)
+ (methods
:initform ()
- :accessor class-incompatible-superclass-list)
- (wrapper
- :initform nil
- :reader class-wrapper)
- (prototype
- :initform nil
- :reader class-prototype)))
-
-(defclass slot-class (pcl-class)
- ((direct-slots
+ :accessor generic-function-methods
+ :type list)
+ (method-class
+ :initarg :method-class
+ :accessor generic-function-method-class)
+ (%method-combination
+ :initarg :method-combination
+ :accessor generic-function-method-combination)
+ (declarations
+ ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
+ ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning
+ ;; might be appropriate).
+ :initarg :declarations
+ :initarg :declare
:initform ()
- :accessor class-direct-slots)
- (slots
+ :accessor generic-function-declarations)
+ (arg-info
+ :initform (make-arg-info)
+ :reader gf-arg-info)
+ (dfun-state
:initform ()
- :accessor class-slots)
- (initialize-info
+ :accessor gf-dfun-state)
+ ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
+ (%lock
+ :initform (sb-thread:make-mutex :name "GF lock")
+ :reader gf-lock)
+ ;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by
+ ;; MAYBE-UPDATE-INFO-FOR-GF.
+ (info-needs-update
:initform nil
- :accessor class-initialize-info)))
-
-;;; The class STD-CLASS is an implementation-specific common
-;;; superclass of the classes STANDARD-CLASS and
-;;; FUNCALLABLE-STANDARD-CLASS.
-(defclass std-class (slot-class)
- ())
-
-(defclass standard-class (std-class)
- ())
-
-(defclass funcallable-standard-class (std-class)
- ())
-
-(defclass forward-referenced-class (pcl-class) ())
-
-(defclass built-in-class (pcl-class) ())
-
-(defclass structure-class (slot-class)
- ((defstruct-form
- :initform ()
- :accessor class-defstruct-form)
- (defstruct-constructor
- :initform nil
- :accessor class-defstruct-constructor)
- (from-defclass-p
+ :accessor gf-info-needs-update))
+ (:metaclass funcallable-standard-class)
+ (:default-initargs :method-class *the-class-standard-method*
+ :method-combination *standard-method-combination*))
+
+(defclass method (metaobject) ())
+
+(defclass standard-method (plist-mixin definition-source-mixin method)
+ ((%generic-function :initform nil :accessor method-generic-function)
+ (qualifiers :initform () :initarg :qualifiers :reader method-qualifiers)
+ (specializers :initform () :initarg :specializers
+ :reader method-specializers)
+ (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list)
+ (%function :initform nil :initarg :function :reader method-function)
+ (%documentation :initform nil :initarg :documentation)
+ ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or
+ ;; just a plain (CALL-NEXT-METHOD).
+ (simple-next-method-call
:initform nil
- :initarg :from-defclass-p)))
-
-(defclass specializer-with-object (specializer) ())
+ :initarg simple-next-method-call
+ :reader simple-next-method-call-p)))
-(defclass exact-class-specializer (specializer) ())
+(defclass accessor-method (standard-method)
+ ((slot-name :initform nil :initarg :slot-name
+ :reader accessor-method-slot-name)))
-(defclass class-eq-specializer (exact-class-specializer
- specializer-with-object)
- ((object :initarg :class
- :reader specializer-class
- :reader specializer-object)))
+(defclass standard-accessor-method (accessor-method)
+ ((%slot-definition :initform nil :initarg :slot-definition
+ :reader accessor-method-slot-definition)))
-(defclass class-prototype-specializer (specializer-with-object)
- ((object :initarg :class
- :reader specializer-class
- :reader specializer-object)))
+(defclass standard-reader-method (standard-accessor-method) ())
+(defclass standard-writer-method (standard-accessor-method) ())
+;;; an extension, apparently.
+(defclass standard-boundp-method (standard-accessor-method) ())
-(defclass eql-specializer (exact-class-specializer specializer-with-object)
- ((object :initarg :object :reader specializer-object
- :reader eql-specializer-object)))
+;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
+;;; can't be STANDARD-READER-METHOD because there is no associated
+;;; slot definition.
+(defclass global-reader-method (accessor-method) ())
+(defclass global-writer-method (accessor-method) ())
+(defclass global-boundp-method (accessor-method) ())
-(defvar *eql-specializer-table* (make-hash-table :test 'eql))
+(defclass method-combination (metaobject)
+ ((%documentation :initform nil :initarg :documentation)))
-(defun intern-eql-specializer (object)
- (or (gethash object *eql-specializer-table*)
- (setf (gethash object *eql-specializer-table*)
- (make-instance 'eql-specializer :object object))))
-\f
-;;;; slot definitions
+(defclass standard-method-combination (definition-source-mixin
+ method-combination)
+ ((type-name
+ :reader method-combination-type-name
+ :initarg :type-name)
+ (options
+ :reader method-combination-options
+ :initarg :options)))
-(defclass slot-definition (standard-object)
+(defclass long-method-combination (standard-method-combination)
+ ((function
+ :initarg :function
+ :reader long-method-combination-function)
+ (args-lambda-list
+ :initarg :args-lambda-list
+ :reader long-method-combination-args-lambda-list)))
+
+(defclass short-method-combination (standard-method-combination)
+ ((operator
+ :reader short-combination-operator
+ :initarg :operator)
+ (identity-with-one-argument
+ :reader short-combination-identity-with-one-argument
+ :initarg :identity-with-one-argument)))
+
+(defclass slot-definition (metaobject)
((name
:initform nil
:initarg :name
:initform nil
:initarg :initfunction
:accessor slot-definition-initfunction)
- (readers
- :initform nil
- :initarg :readers
- :accessor slot-definition-readers)
- (writers
- :initform nil
- :initarg :writers
- :accessor slot-definition-writers)
(initargs
:initform nil
:initarg :initargs
:accessor slot-definition-initargs)
- (type
- :initform t
- :initarg :type
- :accessor slot-definition-type)
- (documentation
- :initform ""
- :initarg :documentation)
- (class
- :initform nil
- :initarg :class
- :accessor slot-definition-class)))
+ (%type :initform t :initarg :type :accessor slot-definition-type)
+ (%documentation
+ :initform nil :initarg :documentation
+ ;; KLUDGE: we need a reader for bootstrapping purposes, in
+ ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
+ :reader %slot-definition-documentation)
+ (%class :initform nil :initarg :class :accessor slot-definition-class)))
(defclass standard-slot-definition (slot-definition)
((allocation
:initform :instance
:initarg :allocation
- :accessor slot-definition-allocation)))
+ :accessor slot-definition-allocation)
+ (allocation-class
+ :initform nil
+ :initarg :allocation-class
+ :accessor slot-definition-allocation-class)))
+
+(defclass condition-slot-definition (slot-definition)
+ ((allocation
+ :initform :instance
+ :initarg :allocation
+ :accessor slot-definition-allocation)
+ (allocation-class
+ :initform nil
+ :initarg :allocation-class
+ :accessor slot-definition-allocation-class)))
(defclass structure-slot-definition (slot-definition)
((defstruct-accessor-symbol
:accessor slot-definition-internal-writer-function)))
(defclass direct-slot-definition (slot-definition)
- ())
+ ((readers
+ :initform nil
+ :initarg :readers
+ :accessor slot-definition-readers)
+ (writers
+ :initform nil
+ :initarg :writers
+ :accessor slot-definition-writers)))
(defclass effective-slot-definition (slot-definition)
- ((reader-function ; (lambda (object) ...)
- :accessor slot-definition-reader-function)
- (writer-function ; (lambda (new-value object) ...)
- :accessor slot-definition-writer-function)
- (boundp-function ; (lambda (object) ...)
- :accessor slot-definition-boundp-function)
- (accessor-flags
- :initform 0)))
+ ((accessor-flags
+ :initform 0)
+ (info
+ :accessor slot-definition-info)))
+
+;;; We use a structure here, because fast slot-accesses to this information
+;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
+;;; these functions can access the SLOT-INFO directly, avoiding the overhead
+;;; of accessing a standard-instance.
+(defstruct (slot-info (:constructor make-slot-info
+ (&key slotd
+ typecheck
+ (type t)
+ (reader
+ (uninitialized-accessor-function :reader slotd))
+ (writer
+ (uninitialized-accessor-function :writer slotd))
+ (boundp
+ (uninitialized-accessor-function :boundp slotd)))))
+ (typecheck nil :type (or null function))
+ (reader (missing-arg) :type function)
+ (writer (missing-arg) :type function)
+ (boundp (missing-arg) :type function))
(defclass standard-direct-slot-definition (standard-slot-definition
- direct-slot-definition)
+ direct-slot-definition)
())
(defclass standard-effective-slot-definition (standard-slot-definition
- effective-slot-definition)
+ effective-slot-definition)
((location ; nil, a fixnum, a cons: (slot-name . value)
:initform nil
:accessor slot-definition-location)))
+(defclass condition-direct-slot-definition (condition-slot-definition
+ direct-slot-definition)
+ ())
+
+(defclass condition-effective-slot-definition (condition-slot-definition
+ effective-slot-definition)
+ ())
+
(defclass structure-direct-slot-definition (structure-slot-definition
- direct-slot-definition)
+ direct-slot-definition)
())
(defclass structure-effective-slot-definition (structure-slot-definition
- effective-slot-definition)
+ effective-slot-definition)
())
-(defclass method (standard-object) ())
-
-(defclass standard-method (definition-source-mixin plist-mixin method)
- ((generic-function
- :initform nil
- :accessor method-generic-function)
-;;; (qualifiers
-;;; :initform ()
-;;; :initarg :qualifiers
-;;; :reader method-qualifiers)
- (specializers
- :initform ()
- :initarg :specializers
- :reader method-specializers)
- (lambda-list
- :initform ()
- :initarg :lambda-list
- :reader method-lambda-list)
- (function
- :initform nil
- :initarg :function) ;no writer
- (fast-function
- :initform nil
- :initarg :fast-function ;no writer
- :reader method-fast-function)
-;;; (documentation
-;;; :initform nil
-;;; :initarg :documentation
-;;; :reader method-documentation)
- ))
-
-(defclass standard-accessor-method (standard-method)
- ((slot-name :initform nil
- :initarg :slot-name
- :reader accessor-method-slot-name)
- (slot-definition :initform nil
- :initarg :slot-definition
- :reader accessor-method-slot-definition)))
+(defclass specializer (metaobject)
+ ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
+ ;; external symbol of the CL package and hence potentially collides
+ ;; with user code. Renaming this to %TYPE, however, is the coward's
+ ;; way out, because the objects that PCL puts in this slot aren't
+ ;; (quite) types: they are closer to kinds of specializer. However,
+ ;; the wholesale renaming and disentangling of specializers didn't
+ ;; appeal. (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
+ ;; responses in comp.lang.lisp). -- CSR, 2006-02-27
+ ((%type :initform nil :reader specializer-type)))
+
+;;; STANDARD in this name doesn't mean "blessed by a standard" but
+;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
+;;; and vestiges of PROTOTYPE specializers
+(defclass standard-specializer (specializer) ())
-(defclass standard-reader-method (standard-accessor-method) ())
+(defclass specializer-with-object (specializer) ())
-(defclass standard-writer-method (standard-accessor-method) ())
+(defclass exact-class-specializer (specializer) ())
-(defclass standard-boundp-method (standard-accessor-method) ())
+(defclass class-eq-specializer (standard-specializer
+ exact-class-specializer
+ specializer-with-object)
+ ((object :initarg :class
+ :reader specializer-class
+ :reader specializer-object)))
-(defclass generic-function (dependent-update-mixin
- definition-source-mixin
- documentation-mixin
- funcallable-standard-object)
- (;; We need to make a distinction between the methods initially set
- ;; up by :METHOD options to DEFGENERIC and the ones set up later by
- ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
- ;; an already-DEFGENERICed function clears the methods set by the
- ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
- ;; this distinction seems a little kludgy, but it has the positive
- ;; effect of making it so that loading a file a.lisp containing
- ;; DEFGENERIC, then loading a second file b.lisp containing
- ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
- ;; tends to leave the generic function in a state consistent with
- ;; the most-recently-loaded state of a.lisp and b.lisp.)
- (initial-methods
- :initform ()
- :accessor generic-function-initial-methods))
- (:metaclass funcallable-standard-class))
+(defclass class-prototype-specializer (standard-specializer specializer-with-object)
+ ((object :initarg :class
+ :reader specializer-class
+ :reader specializer-object)))
-(defclass standard-generic-function (generic-function)
+(defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
+ ((object :initarg :object :reader specializer-object
+ :reader eql-specializer-object)))
+
+(defvar *eql-specializer-table* (make-hash-table :test 'eql))
+
+(defun intern-eql-specializer (object)
+ ;; Need to lock, so that two threads don't get non-EQ specializers
+ ;; for an EQL object.
+ (with-locked-system-table (*eql-specializer-table*)
+ (or (gethash object *eql-specializer-table*)
+ (setf (gethash object *eql-specializer-table*)
+ (make-instance 'eql-specializer :object object)))))
+
+(defclass class (dependent-update-mixin
+ definition-source-mixin
+ standard-specializer)
((name
:initform nil
:initarg :name
- :accessor generic-function-name)
- (methods
+ :reader class-name)
+ (class-eq-specializer
+ :initform nil
+ :reader class-eq-specializer)
+ (direct-superclasses
:initform ()
- :accessor generic-function-methods
- :type list)
- (method-class
- :initarg :method-class
- :accessor generic-function-method-class)
- (method-combination
- :initarg :method-combination
- :accessor generic-function-method-combination)
- (arg-info
- :initform (make-arg-info)
- :reader gf-arg-info)
- (dfun-state
+ :reader class-direct-superclasses)
+ ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
+ ;; CONDITION-CLASSes are lazily computed whenever the subclass info
+ ;; becomes available, i.e. when the PCL class is created.
+ (direct-subclasses
:initform ()
- :accessor gf-dfun-state))
- (:metaclass funcallable-standard-class)
- (:default-initargs :method-class *the-class-standard-method*
- :method-combination *standard-method-combination*))
+ :reader class-direct-subclasses)
+ (direct-methods
+ :initform (cons nil nil))
+ (%documentation
+ :initform nil
+ :initarg :documentation)
+ ;; True if the class definition was compiled with a (SAFETY 3)
+ ;; optimization policy.
+ (safe-p
+ :initform nil
+ :initarg safe-p
+ :accessor safe-p)
+ (finalized-p
+ :initform nil
+ :reader class-finalized-p)))
+
+(def!method make-load-form ((class class) &optional env)
+ ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
+ ;; doesn't matter while all our environments are the same...
+ (declare (ignore env))
+ (let ((name (class-name class)))
+ (unless (and name (eq (find-class name nil) class))
+ (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
+ class))
+ `(find-class ',name)))
-(defclass method-combination (standard-object) ())
+;;; The class PCL-CLASS is an implementation-specific common
+;;; superclass of all specified subclasses of the class CLASS.
+(defclass pcl-class (class)
+ ((%class-precedence-list
+ :reader class-precedence-list)
+ ;; KLUDGE: see note in CPL-OR-NIL
+ (cpl-available-p
+ :reader cpl-available-p
+ :initform nil)
+ (can-precede-list
+ :initform ()
+ :reader class-can-precede-list)
+ (incompatible-superclass-list
+ :initform ()
+ :accessor class-incompatible-superclass-list)
+ (wrapper
+ :initform nil
+ :reader class-wrapper)
+ (prototype
+ :initform nil
+ :reader class-prototype)))
-(defclass standard-method-combination (definition-source-mixin
- method-combination)
- ((type
- :reader method-combination-type
- :initarg :type)
- (documentation
- :reader method-combination-documentation
- :initarg :documentation)
- (options
- :reader method-combination-options
- :initarg :options)))
+(defclass slot-class (pcl-class)
+ ((direct-slots
+ :initform ()
+ :reader class-direct-slots)
+ (slots
+ :initform ()
+ :reader class-slots)))
+
+;;; The class STD-CLASS is an implementation-specific common
+;;; superclass of the classes STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
+(defclass std-class (slot-class)
+ ())
+
+(defclass standard-class (std-class)
+ ()
+ (:default-initargs
+ :direct-superclasses (list *the-class-standard-object*)))
+
+(defclass funcallable-standard-class (std-class)
+ ()
+ (:default-initargs
+ :direct-superclasses (list *the-class-funcallable-standard-object*)))
+
+(defclass forward-referenced-class (pcl-class) ())
+
+(defclass built-in-class (pcl-class) ())
+
+(defclass condition-class (slot-class) ())
+
+(defclass structure-class (slot-class)
+ ((defstruct-form :initform () :accessor class-defstruct-form)
+ (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
+ (from-defclass-p :initform nil :initarg :from-defclass-p)))
+
+(defclass definition-source-mixin (standard-object)
+ ((source
+ :initform nil
+ :reader definition-source
+ :initarg :definition-source)))
+
+(defclass plist-mixin (standard-object)
+ ((plist :initform () :accessor object-plist :initarg plist)))
+
+(defclass dependent-update-mixin (plist-mixin) ())
(defparameter *early-class-predicates*
'((specializer specializerp)
+ (standard-specializer standard-specializer-p)
(exact-class-specializer exact-class-specializer-p)
(class-eq-specializer class-eq-specializer-p)
(eql-specializer eql-specializer-p)
(std-class std-class-p)
(standard-class standard-class-p)
(funcallable-standard-class funcallable-standard-class-p)
+ (condition-class condition-class-p)
(structure-class structure-class-p)
(forward-referenced-class forward-referenced-class-p)
(method method-p)
(standard-method standard-method-p)
+ (accessor-method accessor-method-p)
(standard-accessor-method standard-accessor-method-p)
(standard-reader-method standard-reader-method-p)
(standard-writer-method standard-writer-method-p)
(standard-boundp-method standard-boundp-method-p)
+ (global-reader-method global-reader-method-p)
+ (global-writer-method global-writer-method-p)
+ (global-boundp-method global-boundp-method-p)
(generic-function generic-function-p)
(standard-generic-function standard-generic-function-p)
- (method-combination method-combination-p)))
-
+ (method-combination method-combination-p)
+ (long-method-combination long-method-combination-p)
+ (short-method-combination short-method-combination-p)))
projects / sbcl.git / blobdiff