X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefs.lisp;h=2de8e271a574cd59563ec5f0c8662bdc4045486c;hb=cd99f20d910298cbf5c2000e3dc3595fb0c8418b;hp=4df534afd8f8c243e8d519fbf10f6e465d7a2170;hpb=106e6fe2df729b6027718f6f056721a95c047c17;p=sbcl.git diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 4df534a..2de8e27 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -83,50 +83,6 @@ (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*)) - ;;;; type specifier hackery ;;; internal to this file @@ -148,9 +104,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 +144,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 +173,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) @@ -282,19 +216,13 @@ (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*))) + (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*))) + (let ((symbol (make-wrapper-symbol class-name))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) @@ -306,36 +234,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)) @@ -348,74 +251,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 '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) @@ -423,52 +274,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 (cl:find-class name))) + (class (find-classoid name)) + (prototype-form + (getf (cdr kernel-bic-entry) :prototype-form))) (/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)))) - ,(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*") @@ -478,22 +315,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,10 +343,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)) @@ -517,7 +356,7 @@ (defclass definition-source-mixin (std-object) ((source - :initform *load-truename* + :initform *load-pathname* :reader definition-source :initarg :definition-source)) (:metaclass std-class)) @@ -528,19 +367,14 @@ :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 +;;; 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 @@ -553,6 +387,9 @@ (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) @@ -560,13 +397,33 @@ :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. (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) @@ -586,10 +443,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 @@ -607,6 +461,8 @@ (defclass built-in-class (pcl-class) ()) +(defclass condition-class (slot-class) ()) + (defclass structure-class (slot-class) ((defstruct-form :initform () @@ -676,7 +532,7 @@ :initarg :type :accessor slot-definition-type) (documentation - :initform "" + :initform nil :initarg :documentation) (class :initform nil @@ -687,7 +543,21 @@ ((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 @@ -726,6 +596,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) ()) @@ -759,11 +637,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 @@ -781,11 +657,13 @@ (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 + ;; 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 @@ -814,6 +692,10 @@ (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) @@ -824,20 +706,29 @@ (: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))) +(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) (exact-class-specializer exact-class-specializer-p) @@ -848,6 +739,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) @@ -858,5 +750,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)))