X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=2ec1da607215a761c6de3046255ca975464c37d5;hb=8b313a75eb6bcc7b1c8eda798c8350b49f94861c;hp=5943a8db63033eda17475a789701e6ffb663b987;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 5943a8d..2ec1da6 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -53,17 +53,16 @@ (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. +;;; 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 or advised, redefine -;;; the `real' definition without affecting the advise. +;;; 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::%%defun name new-definition nil) (sb-c::note-name-defined name :function) new-definition) (setf (fdefinition name) new-definition)) @@ -130,14 +129,14 @@ ;;;; type specifier hackery -;;; internal to this file. +;;; internal to this file (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)) class)) -;;; Interface +;;; interface (defun specializer-from-type (type &aux args) (when (consp type) (setq args (cdr type) type (car type))) @@ -178,7 +177,7 @@ (if (atom type) (if (eq type t) *the-class-t* - (error "bad argument to type-class")) + (error "bad argument to TYPE-CLASS")) (case (car type) (eql (class-of (cadr type))) (prototype (class-of (cadr type))) ;? @@ -188,44 +187,9 @@ (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) @@ -246,24 +210,6 @@ (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))))))) - ;;; internal to this file... (defun convert-to-system-type (type) (case (car type) @@ -276,21 +222,13 @@ (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. +;;; 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? (defun *subtypep (type1 type2) (if (equal type1 type2) (values t t) @@ -298,15 +236,16 @@ (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. + ;; 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)) ; Should improve this. + (values nil nil)) ; XXX We should improve this. (and - (values nil nil)) ; Should improve this. + (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) @@ -314,22 +253,6 @@ (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))))) (defvar *built-in-class-symbols* ()) (defvar *built-in-wrapper-symbols* ()) @@ -352,11 +275,11 @@ (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) -(pushnew '%class *variable-declarations*) -(pushnew '%variable-rebinding *variable-declarations*) +(pushnew '%class *var-declarations*) +(pushnew '%variable-rebinding *var-declarations*) (defun variable-class (var env) - (caddr (variable-declaration 'class var env))) + (caddr (var-declaration 'class var env))) (defvar *name->class->slotd-table* (make-hash-table)) @@ -381,7 +304,7 @@ (defmacro define-gf-predicate (predicate-name &rest classes) `(progn (defmethod ,predicate-name ((x t)) nil) - ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) + ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) classes))) (defun make-class-predicate-name (name) @@ -459,22 +382,22 @@ (/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)) + (/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)))) - (/show inherits) + (/noshow inherits) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) - (/show "entering DIRECT-SUBS" (sb-kernel::class-name class)) + (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class)) (collect ((res)) (let ((subs (sb-kernel:class-subclasses class))) - (/show subs) + (/noshow subs) (when subs (dohash (sub v subs) (declare (ignore v)) - (/show sub) + (/noshow sub) (when (member class (direct-supers sub)) (res sub))))) (res))) @@ -502,10 +425,10 @@ ;; relevant cases. 42)))) (mapcar (lambda (kernel-bic-entry) - (/show "setting up" kernel-bic-entry) + (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) (class (cl:find-class name))) - (/show name class) + (/noshow name class) `(,name ,(mapcar #'cl:class-name (direct-supers class)) ,(mapcar #'cl:class-name (direct-subs class)) @@ -525,7 +448,7 @@ sb-kernel:funcallable-instance function stream))) sb-kernel::*built-in-classes*)))) -(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*") +(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") ;;;; the classes that define the kernel of the metabraid @@ -541,7 +464,7 @@ (defclass sb-kernel:funcallable-instance (function) () (:metaclass built-in-class)) -(defclass stream (t) () +(defclass stream (sb-kernel:instance) () (:metaclass built-in-class)) (defclass slot-object (t) () @@ -561,90 +484,96 @@ (defclass funcallable-standard-object (std-object sb-kernel:funcallable-instance) - () + () (:metaclass funcallable-standard-class)) (defclass specializer (standard-object) - ((type - :initform nil - :reader specializer-type))) + ((type + :initform nil + :reader specializer-type))) (defclass definition-source-mixin (std-object) - ((source - :initform *load-truename* - :reader definition-source - :initarg :definition-source)) + ((source + :initform *load-truename* + :reader definition-source + :initarg :definition-source)) (:metaclass std-class)) (defclass plist-mixin (std-object) - ((plist - :initform () - :accessor object-plist)) + ((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. +;;; 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) + ;; 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 - :initform () - :accessor class-incompatible-superclass-list) - (wrapper - :initform nil - :reader class-wrapper) - (prototype - :initform nil - :reader class-prototype))) + ((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. + ((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) ()) @@ -698,41 +627,41 @@ ;;;; 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))) + ((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))) (defclass standard-slot-definition (slot-definition) ((allocation @@ -758,11 +687,11 @@ ()) (defclass effective-slot-definition (slot-definition) - ((reader-function ; #'(lambda (object) ...) + ((reader-function ; (lambda (object) ...) :accessor slot-definition-reader-function) - (writer-function ; #'(lambda (new-value object) ...) + (writer-function ; (lambda (new-value object) ...) :accessor slot-definition-writer-function) - (boundp-function ; #'(lambda (object) ...) + (boundp-function ; (lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags :initform 0))) @@ -788,41 +717,41 @@ (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) - )) + ((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))) + ((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 standard-reader-method (standard-accessor-method) ()) @@ -834,47 +763,60 @@ 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 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)) + ((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)) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) (defclass method-combination (standard-object) ()) -(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 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))) (defparameter *early-class-predicates* '((specializer specializerp)