X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=dc12f8469dd5446933cee40be968c140fabc6ee3;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=831d8a593056f06450f0476f31e54ed0a4df4b0e;hpb=a92c91a4fdcdcf1c96b33339c1ef077243183187;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 831d8a5..dc12f84 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -102,6 +102,7 @@ *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* + *the-class-condition-class* *the-class-structure-class* *the-class-std-class* *the-class-standard-class* @@ -148,9 +149,10 @@ :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)))) + ;; FIXME: do we still need this? + ((and (null args) (typep type 'classoid)) + (or (classoid-pcl-class type) + (ensure-non-standard-class (classoid-name type)))) ((specializerp type) type))) ;;; interface @@ -187,29 +189,6 @@ (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)))) - -(defun make-type-predicate (name) - (let ((cell (find-class-cell name))) - (lambda (x) - (funcall (the function (find-class-cell-predicate cell)) x)))) - -(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))))) - ;;; internal to this file.. ;;; ;;; These functions are a pale imitation of their namesake. They accept @@ -239,7 +218,7 @@ ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-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) @@ -306,36 +285,11 @@ (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*)) - + (list 'class-predicate name)) + (defun plist-value (object name) (getf (object-plist object) name)) @@ -405,17 +359,17 @@ (/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 "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" (sb-kernel::class-name class)) + (/noshow "entering DIRECT-SUBS" (classoid-name class)) (collect ((res)) - (let ((subs (sb-kernel:class-subclasses class))) + (let ((subs (classoid-subclasses class))) (/noshow subs) (when subs (dohash (sub v subs) @@ -450,25 +404,26 @@ (mapcar (lambda (kernel-bic-entry) (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) - (class (cl:find-class name))) + (class (find-classoid name))) (/noshow name class) `(,name - ,(mapcar #'cl:class-name (direct-supers class)) - ,(mapcar #'cl:class-name (direct-subs class)) + ,(mapcar #'classoid-name (direct-supers class)) + ,(mapcar #'classoid-name (direct-subs class)) ,(map 'list (lambda (x) - (cl:class-name (sb-kernel:layout-class x))) + (classoid-name + (layout-classoid x))) (reverse - (sb-kernel:layout-inherits - (sb-kernel:class-layout class)))) + (layout-inherits + (classoid-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 + '(t instance + funcallable-instance function stream))) sb-kernel::*built-in-classes*)))) (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*") @@ -478,22 +433,25 @@ (defclass t () () (:metaclass built-in-class)) -(defclass sb-kernel:instance (t) () +(defclass instance (t) () (:metaclass built-in-class)) (defclass function (t) () (:metaclass built-in-class)) -(defclass sb-kernel:funcallable-instance (function) () +(defclass funcallable-instance (function) () (:metaclass built-in-class)) -(defclass stream (sb-kernel:instance) () +(defclass stream (instance) () (:metaclass built-in-class)) (defclass slot-object (t) () (:metaclass slot-class)) -(defclass structure-object (slot-object sb-kernel:instance) () +(defclass condition (slot-object instance) () + (:metaclass condition-class)) + +(defclass structure-object (slot-object instance) () (:metaclass structure-class)) (defstruct (dead-beef-structure-object @@ -503,94 +461,112 @@ (defclass std-object (slot-object) () (:metaclass std-class)) -(defclass standard-object (std-object sb-kernel:instance) ()) +(defclass standard-object (std-object instance) ()) -(defclass funcallable-standard-object (std-object - sb-kernel:funcallable-instance) - () +(defclass funcallable-standard-object (std-object 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-pathname* + :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) + (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) - (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) ()) @@ -604,6 +580,8 @@ (defclass built-in-class (pcl-class) ()) +(defclass condition-class (slot-class) ()) + (defclass structure-class (slot-class) ((defstruct-form :initform () @@ -644,47 +622,61 @@ ;;;; 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 :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 @@ -723,6 +715,14 @@ :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) ()) @@ -734,41 +734,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) ()) @@ -780,44 +780,72 @@ 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)) + ((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) + (declarations + :initarg :declarations + :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*)) (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))) + +(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))) (defparameter *early-class-predicates* '((specializer specializerp) @@ -829,6 +857,7 @@ (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) @@ -839,5 +868,6 @@ (standard-boundp-method standard-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)))