X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=597a1b2b5a65fae27b6e85895dbdaba0f7a9436a;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=ba9ff36bc6599977c02bc4b23c86552d812e88f4;hpb=cbaa1997bb097a55d108df592ac3b7eb4a703fff;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index ba9ff36..597a1b2 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -28,105 +28,28 @@ ;;; 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.")) -;;; 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 or advised, return the -;;; unadvised, traced etc. definition. This lets me 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 or advised, redefine -;;; the `real' definition without affecting the advise. -(defun fdefine-carefully (name new-definition) - (progn - (sb-c::%%defun name new-definition nil) - (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)))) - -(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)) ;;;; type specifier hackery @@ -134,262 +57,144 @@ (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))) -(defun inform-type-system-about-std-class (name) - (let ((predicate-name (make-type-predicate-name name))) - (setf (gdefinition predicate-name) - (make-type-predicate name)) - (do-satisfies-deftype name predicate-name))) - -(defun make-type-predicate (name) - (let ((cell (find-class-cell name))) - #'(lambda (x) - (funcall (the function (find-class-cell-predicate cell)) x)))) - -;This stuff isn't right. Good thing it isn't used. -;The satisfies predicate has to be a symbol. There is no way to -;construct such a symbol from a class object if class names change. -(defun class-predicate (class) - (when (symbolp class) (setq class (find-class class))) - #'(lambda (object) (memq class (class-precedence-list (class-of object))))) - -(defun make-class-eq-predicate (class) - (when (symbolp class) (setq class (find-class class))) - #'(lambda (object) (eq class (class-of object)))) - -(defun make-eql-predicate (eql-object) - #'(lambda (object) (eql eql-object object))) - -#|| ; The argument to satisfies must be a symbol. -(deftype class (&optional class) - (if class - `(satisfies ,(class-predicate class)) - `(satisfies ,(class-predicate 'class)))) - -(deftype class-eq (class) - `(satisfies ,(make-class-eq-predicate class))) -||# - -;;; internal to this file +;;; internal to this file.. ;;; -;;; These functions are a pale imitiation of their namesake. They accept +;;; These functions are a pale imitation of their namesake. They accept ;;; 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)))) - -;;; Not used... -#+nil -(defun unparse-type-list (tlist) - (mapcar #'unparse-type tlist)) - -;;; Not used... -#+nil -(defun unparse-type (type) - (if (atom type) - (if (specializerp type) - (unparse-type (specializer-type type)) - type) - (case (car type) - (eql type) - (class-eq `(class-eq ,(class-name (cadr type)))) - (class (class-name (cadr type))) - (t `(,(car type) ,@(unparse-type-list (cdr 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)))) - -;;; not used... -#+nil -(defun *typep (object type) - (setq type (*normalize-type type)) - (cond ((member (car type) '(eql wrapper-eq class-eq class)) - (specializer-applicable-using-type-p type `(eql ,object))) - ((eq (car type) 'not) - (not (*typep object (cadr type)))) - (t - (typep object (convert-to-system-type type))))) - -;;; Writing the missing NOT and AND clauses will improve -;;; the quality of code generated by generate-discrimination-net, but -;;; calling subtypep in place of just returning (values nil nil) can be -;;; very slow. *SUBTYPEP is used by PCL itself, and must be fast. + (car type) + type)))) + +;;; Writing the missing NOT and AND clauses will improve the quality +;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling +;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very +;;; 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? +(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*)) - ;; *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)) ; Should improve this. - (and - (values nil nil)) ; 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)))))))) - -(defun do-satisfies-deftype (name predicate) - (declare (ignore name predicate))) - -(defun make-type-predicate-name (name &optional kind) - (if (symbol-package name) - (intern (format nil - "~@[~A ~]TYPE-PREDICATE ~A ~A" - kind - (package-name (symbol-package name)) - (symbol-name name)) - *pcl-package*) - (make-symbol (format nil - "~@[~A ~]TYPE-PREDICATE ~A" - kind - (symbol-name name))))) + (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)))))))) (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))) -(pushnew '%class *variable-declarations*) -(pushnew '%variable-rebinding *variable-declarations*) - -(defun variable-class (var env) - (caddr (variable-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*)) ;*** -(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)) @@ -397,348 +202,281 @@ (if new-value (setf (getf (object-plist object) name) new-value) (progn - (remf (object-plist object) name) - nil))) + (remf (object-plist object) name) + nil))) ;;;; 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) - (/show "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)))) - (/show inherits) - (list (svref inherits (1- (length inherits))))))) - (direct-subs (class) - (/show "entering DIRECT-SUBS" (sb-kernel::class-name class)) - (collect ((res)) - (let ((subs (sb-kernel:class-subclasses class))) - (/show subs) - (when subs - (dohash (sub v subs) - (declare (ignore v)) - (/show 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) - (/show "setting up" kernel-bic-entry) - (let* ((name (car kernel-bic-entry)) - (class (cl:find-class name))) - (/show 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*)))) -(/show "done setting up SB-PCL::*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*") ;;;; 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 (t) () +(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))) + (: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 sb-kernel:instance) ()) - -(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 documentation-mixin (plist-mixin) - () - (:metaclass std-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) - ((name - :initform nil - :initarg :name - :accessor class-name) - (class-eq-specializer - :initform nil - :reader class-eq-specializer) - (direct-superclasses - :initform () - :reader class-direct-superclasses) - (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 - :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 - :initform () - :accessor class-direct-slots) - (slots - :initform () - :accessor class-slots) - (initialize-info - :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 metaobject (standard-object) ()) -(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 +(defclass generic-function (dependent-update-mixin + definition-source-mixin + metaobject + funcallable-standard-object) + ((%documentation :initform nil - :initarg :from-defclass-p))) - -(defclass specializer-with-object (specializer) ()) - -(defclass exact-class-specializer (specializer) ()) + :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 class-eq-specializer (exact-class-specializer - specializer-with-object) - ((object :initarg :class - :reader specializer-class - :reader specializer-object))) +(defclass standard-generic-function (generic-function) + ((name + :initform nil + :initarg :name + :reader 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) + ;; 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 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 simple-next-method-call + :reader simple-next-method-call-p))) -(defclass class-prototype-specializer (specializer-with-object) - ((object :initarg :class - :reader specializer-class - :reader specializer-object))) +(defclass accessor-method (standard-method) + ((slot-name :initform nil :initarg :slot-name + :reader accessor-method-slot-name))) -(defclass eql-specializer (exact-class-specializer specializer-with-object) - ((object :initarg :object :reader specializer-object - :reader eql-specializer-object))) +(defclass standard-accessor-method (accessor-method) + ((%slot-definition :initform nil :initarg :slot-definition + :reader accessor-method-slot-definition))) -(defvar *eql-specializer-table* (make-hash-table :test 'eql)) +(defclass standard-reader-method (standard-accessor-method) ()) +(defclass standard-writer-method (standard-accessor-method) ()) +;;; an extension, apparently. +(defclass standard-boundp-method (standard-accessor-method) ()) -(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 slot-definition (standard-object) - ((name - :initform nil - :initarg :name - :accessor slot-definition-name) - (initform - :initform nil - :initarg :initform - :accessor slot-definition-initform) - (initfunction - :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))) +;;; 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 method-combination (metaobject) + ((%documentation :initform nil :initarg :documentation))) + +(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 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 + :accessor slot-definition-name) + (initform + :initform nil + :initarg :initform + :accessor slot-definition-initform) + (initfunction + :initform nil + :initarg :initfunction + :accessor slot-definition-initfunction) + (initargs + :initform nil + :initarg :initargs + :accessor slot-definition-initargs) + (%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 @@ -755,129 +493,227 @@ :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 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) - () - (: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) - ((name - :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) - (arg-info - :initform (make-arg-info) - :reader gf-arg-info) - (dfun-state - :initform () - :accessor gf-dfun-state) - (pretty-arglist - :initform () - :accessor gf-pretty-arglist)) - (:metaclass funcallable-standard-class) - (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) +(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 method-combination (standard-object) ()) +(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 + :reader 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)) + (%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 "~@" + 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 + :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) @@ -886,15 +722,21 @@ (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)))