(parse-gspec spec
(name (fdefine-carefully name new-value))))
\f
-(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*))
-\f
;;;; type specifier hackery
;;; internal to this file
;; FIXME: do we still need this?
((and (null args) (typep type 'classoid))
(or (classoid-pcl-class type)
- (ensure-non-structure-class (classoid-name type))))
+ (ensure-non-standard-class (classoid-name type))))
((specializerp type) type)))
;;; interface
\f
;;;; 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*")
(/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 (find-classoid name)))
+ (class (find-classoid name))
+ (prototype-form
+ (getf (cdr kernel-bic-entry) :prototype-form)))
(/noshow name class)
`(,name
,(mapcar #'classoid-name (direct-supers class))
(reverse
(layout-inherits
(classoid-layout class))))
- ,(prototype name))))
+ ,(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
(defclass slot-object (t) ()
(:metaclass slot-class))
+(defclass condition (slot-object instance) ()
+ (:metaclass condition-class))
+
(defclass structure-object (slot-object instance) ()
(:metaclass structure-class))
: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
+(defclass class (dependent-update-mixin
definition-source-mixin
specializer)
((name
: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 "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
+ class))
+ `(find-class ',name)))
;;; The class PCL-CLASS is an implementation-specific common
;;; superclass of all specified subclasses of the class CLASS.
: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
(defclass built-in-class (pcl-class) ())
-(defclass condition-class (pcl-class) ())
+(defclass condition-class (slot-class) ())
(defclass structure-class (slot-class)
((defstruct-form
:initarg :type
:accessor slot-definition-type)
(documentation
- :initform ""
+ :initform nil
:initarg :documentation)
(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
:initform nil
: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)
())
: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
(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
(: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)))
(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)
projects / sbcl.git / blobdiff