X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=84811bdbc53d070d1b1a4d467cedf784fd95e7f2;hb=4ed3f0d08c3a57a6762018d9622f253ab9d0f2b6;hp=a39b78d50f364126150a8095e8db5f867c814936;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index a39b78d..84811bd 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* @@ -149,9 +150,9 @@ (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 'sb-kernel:classoid)) - (or (sb-kernel:classoid-pcl-class type) - (find-structure-class (sb-kernel:classoid-name type)))) + ((and (null args) (typep type 'classoid)) + (or (classoid-pcl-class type) + (ensure-non-standard-class (classoid-name type)))) ((specializerp type) type))) ;;; interface @@ -217,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-classoid (class-wrapper (cadr type)))) + (layout-classoid (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) @@ -301,74 +302,22 @@ ;;;; built-in classes -;;; FIXME: This was the portable PCL way of setting up -;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost -;;; entirely wasted motion, since it's immediately overwritten by a -;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However, -;;; we can't just delete it, since the fifth element from each entry -;;; (a prototype of the class) is still in the final result. It would -;;; be nice to clean this up so that the other, never-used stuff is -;;; gone, perhaps finding a tidier way to represent examples of each -;;; class, too. -;;; -;;; FIXME: This can probably be blown away after bootstrapping. -;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too.. -#| -(defvar *built-in-classes* - ;; name supers subs cdr of cpl - ;; prototype - '(;(t () (number sequence array character symbol) ()) - (number (t) (complex float rational) (t)) - (complex (number) () (number t) - #c(1 1)) - (float (number) () (number t) - 1.0) - (rational (number) (integer ratio) (number t)) - (integer (rational) () (rational number t) - 1) - (ratio (rational) () (rational number t) - 1/2) - - (sequence (t) (list vector) (t)) - (list (sequence) (cons null) (sequence t)) - (cons (list) () (list sequence t) - (nil)) - - (array (t) (vector) (t) - #2A((nil))) - (vector (array - sequence) (string bit-vector) (array sequence t) - #()) - (string (vector) () (vector array sequence t) - "") - (bit-vector (vector) () (vector array sequence t) - #*1) - (character (t) () (t) - #\c) - - (symbol (t) (null) (t) - symbol) - (null (symbol - list) () (symbol list sequence t) - nil))) -|# - ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set ;;; SB-PCL:*BUILT-IN-CLASSES*. (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*") (defvar *built-in-classes* (labels ((direct-supers (class) - (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class)) - (if (typep class 'sb-kernel:built-in-classoid) - (sb-kernel:built-in-classoid-direct-superclasses class) - (let ((inherits (sb-kernel:layout-inherits - (sb-kernel:classoid-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:classoid-subclasses class))) + (let ((subs (classoid-subclasses class))) (/noshow subs) (when subs (dohash (sub v subs) @@ -376,53 +325,38 @@ (/noshow sub) (when (member class (direct-supers sub)) (res sub))))) - (res))) - (prototype (class-name) - (let ((assoc (assoc class-name - '((complex . #c(1 1)) - (float . 1.0) - (integer . 1) - (ratio . 1/2) - (sequence . nil) - (list . nil) - (cons . (nil)) - (array . #2a((nil))) - (vector . #()) - (string . "") - (bit-vector . #*1) - (character . #\c) - (symbol . symbol) - (null . nil))))) - (if assoc - (cdr assoc) - ;; This is the default prototype value which was - ;; used, without explanation, by the CMU CL code - ;; we're derived from. Evidently it's safe in all - ;; relevant cases. - 42)))) + (res)))) (mapcar (lambda (kernel-bic-entry) (/noshow "setting up" kernel-bic-entry) (let* ((name (car kernel-bic-entry)) - (class (sb-kernel:find-classoid name))) + (class (find-classoid name)) + (prototype-form + (getf (cdr kernel-bic-entry) :prototype-form))) (/noshow name class) `(,name - ,(mapcar #'sb-kernel:classoid-name (direct-supers class)) - ,(mapcar #'sb-kernel:classoid-name (direct-subs class)) + ,(mapcar #'classoid-name (direct-supers class)) + ,(mapcar #'classoid-name (direct-subs class)) ,(map 'list (lambda (x) - (sb-kernel:classoid-name - (sb-kernel:layout-classoid x))) + (classoid-name + (layout-classoid x))) (reverse - (sb-kernel:layout-inherits - (sb-kernel:classoid-layout class)))) - ,(prototype name)))) + (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 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*") @@ -432,22 +366,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 @@ -457,10 +394,9 @@ (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)) @@ -482,10 +418,6 @@ :accessor object-plist)) (:metaclass std-class)) -(defclass documentation-mixin (plist-mixin) - () - (:metaclass std-class)) - (defclass dependent-update-mixin (plist-mixin) () (:metaclass std-class)) @@ -493,8 +425,7 @@ ;;; 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 +(defclass class (dependent-update-mixin definition-source-mixin specializer) ((name @@ -517,7 +448,23 @@ :initform (cons nil nil)) (predicate-name :initform nil - :reader class-predicate-name))) + :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. @@ -543,10 +490,7 @@ :accessor class-direct-slots) (slots :initform () - :accessor class-slots) - (initialize-info - :initform nil - :accessor class-initialize-info))) + :accessor class-slots))) ;;; The class STD-CLASS is an implementation-specific common ;;; superclass of the classes STANDARD-CLASS and @@ -564,6 +508,8 @@ (defclass built-in-class (pcl-class) ()) +(defclass condition-class (slot-class) ()) + (defclass structure-class (slot-class) ((defstruct-form :initform () @@ -633,7 +579,7 @@ :initarg :type :accessor slot-definition-type) (documentation - :initform "" + :initform nil :initarg :documentation) (class :initform nil @@ -650,6 +596,16 @@ :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 :initform nil @@ -687,6 +643,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) ()) @@ -720,11 +684,9 @@ :initform nil :initarg :fast-function ;no writer :reader method-fast-function) -;;; (documentation -;;; :initform nil -;;; :initarg :documentation -;;; :reader method-documentation) - )) + (documentation + :initform nil + :initarg :documentation))) (defclass standard-accessor-method (standard-method) ((slot-name :initform nil @@ -742,9 +704,11 @@ (defclass generic-function (dependent-update-mixin definition-source-mixin - documentation-mixin funcallable-standard-object) - (;; We need to make a distinction between the methods initially set + ((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's specifies that executing DEFGENERIC on ;; an already-DEFGENERICed function clears the methods set by the @@ -789,16 +753,17 @@ (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) -(defclass method-combination (standard-object) ()) +(defclass method-combination (standard-object) + ((documentation + :reader method-combination-documentation + :initform nil + :initarg :documentation))) (defclass standard-method-combination (definition-source-mixin - method-combination) + method-combination) ((type :reader method-combination-type :initarg :type) - (documentation - :reader method-combination-documentation - :initarg :documentation) (options :reader method-combination-options :initarg :options))) @@ -821,6 +786,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)