X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=985bf5ce97590bffb249a5574178870f2f45afa5;hb=4ec46046e59ce00abe3e53bce16fdfb2c4c57362;hp=ce413de6aa0a6831469971e434e4821167b08607;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index ce413de..985bf5c 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -38,50 +38,18 @@ has already been partially loaded. This may not work, you may~%~ need to get a fresh lisp (reboot) and then load PCL.")) -;;; 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)))) + ;; 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)) ;;;; type specifier hackery @@ -94,11 +62,12 @@ ;;; 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 + (or (ecase type (class (coerce-to-class (car args))) (prototype (make-instance 'class-prototype-specializer :object (coerce-to-class (car args)))) @@ -226,19 +195,8 @@ (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) -(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)) - (defvar *standard-method-combination*) -(defun make-class-predicate-name (name) - (list 'class-predicate name)) - (defun plist-value (object name) (getf (object-plist object) name)) @@ -269,7 +227,7 @@ (let ((subs (classoid-subclasses class))) (/noshow subs) (when subs - (dohash (sub v subs) + (dohash ((sub v) subs) (declare (ignore v)) (/noshow sub) (when (member class (direct-supers sub)) @@ -304,9 +262,7 @@ ;; I'm not sure why these are removed from ;; the list, but that's what the original ;; CMU CL code did. -- WHN 20000715 - '(t instance - funcallable-instance - function stream + '(t function stream file-stream string-stream))) sb-kernel::*built-in-classes*)))) (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") @@ -316,16 +272,10 @@ (defclass t () () (:metaclass built-in-class)) -(defclass instance (t) () - (:metaclass built-in-class)) - (defclass function (t) () (:metaclass built-in-class)) -(defclass funcallable-instance (function) () - (:metaclass built-in-class)) - -(defclass stream (instance) () +(defclass stream (t) () (:metaclass built-in-class)) (defclass file-stream (stream) () @@ -337,179 +287,144 @@ (defclass slot-object (t) () (:metaclass slot-class)) -(defclass condition (slot-object instance) () +(defclass condition (slot-object) () (:metaclass condition-class)) -(defclass structure-object (slot-object instance) () +(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)) +(defclass standard-object (slot-object) ()) -(defclass standard-object (std-object instance) ()) - -(defclass funcallable-standard-object (std-object 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-pathname* - :reader definition-source - :initarg :definition-source)) - (:metaclass std-class)) +(defclass metaobject (standard-object) ()) -(defclass plist-mixin (std-object) - ((plist +(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 object-plist)) - (:metaclass std-class)) - -(defclass dependent-update-mixin (plist-mixin) - () - (:metaclass std-class)) + :accessor generic-function-initial-methods)) + (:metaclass funcallable-standard-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 (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) - (documentation - :initform nil - :initarg :documentation) - (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 "~@" - class)) - `(find-class ',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) - ;; 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 + :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))) - -;;; 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) ()) + :accessor gf-dfun-state) + ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic. + (%lock + :initform (sb-thread::make-spinlock :name "GF lock") + :reader gf-lock)) + (:metaclass funcallable-standard-class) + (:default-initargs :method-class *the-class-standard-method* + :method-combination *standard-method-combination*)) -(defclass built-in-class (pcl-class) ()) +(defclass method (metaobject) ()) -(defclass condition-class (slot-class) ()) +(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))) -(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 accessor-method (standard-method) + ((slot-name :initform nil :initarg :slot-name + :reader accessor-method-slot-name))) -(defclass specializer-with-object (specializer) ()) +(defclass standard-accessor-method (accessor-method) + ((%slot-definition :initform nil :initarg :slot-definition + :reader accessor-method-slot-definition))) -(defclass exact-class-specializer (specializer) ()) +(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 class-eq-specializer (exact-class-specializer - specializer-with-object) - ((object :initarg :class - :reader specializer-class - :reader 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) ()) -(defclass class-prototype-specializer (specializer-with-object) - ((object :initarg :class - :reader specializer-class - :reader specializer-object))) +(defclass method-combination (metaobject) + ((%documentation :initform nil :initarg :documentation))) -(defclass eql-specializer (exact-class-specializer specializer-with-object) - ((object :initarg :object :reader specializer-object - :reader eql-specializer-object))) +(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))) -(defvar *eql-specializer-table* (make-hash-table :test 'eql)) +(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))) -(defun intern-eql-specializer (object) - (or (gethash object *eql-specializer-table*) - (setf (gethash object *eql-specializer-table*) - (make-instance 'eql-specializer :object object)))) - -;;;; slot definitions +(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 (standard-object) +(defclass slot-definition (metaobject) ((name :initform nil :initarg :name @@ -534,17 +449,16 @@ :initform nil :initarg :initargs :accessor slot-definition-initargs) - (type - :initform t - :initarg :type - :accessor slot-definition-type) - (documentation - :initform nil - :initarg :documentation) - (class - :initform nil - :initarg :class - :accessor slot-definition-class))) + (%type :initform t :initarg :type :accessor slot-definition-type) + (%type-check-function :initform nil + :initarg type-check-function + :accessor slot-definition-type-check-function) + (%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 @@ -619,129 +533,172 @@ effective-slot-definition) ()) -(defclass method (standard-object) ()) +(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 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 specializer-with-object (specializer) ()) + +(defclass exact-class-specializer (specializer) ()) + +(defclass class-eq-specializer (standard-specializer + exact-class-specializer + specializer-with-object) + ((object :initarg :class + :reader specializer-class + :reader specializer-object))) + +(defclass class-prototype-specializer (standard-specializer specializer-with-object) + ((object :initarg :class + :reader specializer-class + :reader specializer-object))) + +(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)) -(defclass standard-method (definition-source-mixin plist-mixin method) - ((generic-function +(defvar *eql-specializer-table-lock* + (sb-thread::make-spinlock :name "EQL-specializer table lock")) + +(defun intern-eql-specializer (object) + ;; Need to lock, so that two threads don't get non-EQ specializers + ;; for an EQL object. + (sb-thread::with-spinlock (*eql-specializer-table-lock*) + (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 - :accessor method-generic-function) -;;; (qualifiers -;;; :initform () -;;; :initarg :qualifiers -;;; :reader method-qualifiers) - (specializers + :initarg :name + :reader class-name) + (class-eq-specializer + :initform nil + :reader class-eq-specializer) + (direct-superclasses :initform () - :initarg :specializers - :reader method-specializers) - (lambda-list + :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 () - :initarg :lambda-list - :reader method-lambda-list) - (function + :reader class-direct-subclasses) + (direct-methods + :initform (cons nil nil)) + (%documentation :initform nil - :initarg :function) ;no writer - (fast-function + :initarg :documentation) + ;; True if the class definition was compiled with a (SAFETY 3) + ;; optimization policy. + (safe-p :initform nil - :initarg :fast-function ;no writer - :reader method-fast-function) - (documentation + :initarg safe-p + :accessor safe-p) + (finalized-p :initform nil - :initarg :documentation))) + :reader class-finalized-p))) -(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))) +(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 "~@" + class)) + `(find-class ',name))) -(defclass standard-reader-method (standard-accessor-method) ()) +;;; 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-writer-method (standard-accessor-method) ()) +(defclass slot-class (pcl-class) + ((direct-slots + :initform () + :reader class-direct-slots) + (slots + :initform () + :reader class-slots))) -(defclass standard-boundp-method (standard-accessor-method) ()) +;;; 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 generic-function (dependent-update-mixin - definition-source-mixin - 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)) - (:metaclass funcallable-standard-class)) +(defclass standard-class (std-class) + ()) -(defclass standard-generic-function (generic-function) - ((name +(defclass funcallable-standard-class (std-class) + ()) + +(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 :name - :accessor generic-function-name) - (methods - :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) - (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 generic-function-declarations) - (arg-info - :initform (make-arg-info) - :reader gf-arg-info) - (dfun-state - :initform () - :accessor gf-dfun-state)) - (:metaclass funcallable-standard-class) - (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) + :initarg :from-defclass-p))) -(defclass method-combination (standard-object) - ((documentation - :reader method-combination-documentation +(defclass definition-source-mixin (standard-object) + ((source :initform nil - :initarg :documentation))) + :reader definition-source + :initarg :definition-source))) -(defclass standard-method-combination (definition-source-mixin - method-combination) - ((type - :reader method-combination-type - :initarg :type) - (options - :reader method-combination-options - :initarg :options))) +(defclass plist-mixin (standard-object) + ((plist :initform () :accessor object-plist :initarg plist))) -(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 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) @@ -755,12 +712,16 @@ (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) - (long-method-combination long-method-combination-p))) - + (long-method-combination long-method-combination-p) + (short-method-combination short-method-combination-p)))