;;;; This file contains structures and functions for the maintenance of
;;;; basic information about defined types. Different object systems
-;;;; can be supported simultaneously. Some of the functions here are
-;;;; nominally generic, and are overwritten when CLOS is loaded.
+;;;; can be supported simultaneously.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(!begin-collecting-cold-init-forms)
\f
-;;;; the CLASS structure
+;;;; the CLASSOID structure
-;;; The CLASS structure is a supertype of all class types. A CLASS is
-;;; also a CTYPE structure as recognized by the type system.
+;;; The CLASSOID structure is a supertype of all classoid types. A
+;;; CLASSOID is also a CTYPE structure as recognized by the type
+;;; system. (FIXME: It's also a type specifier, though this might go
+;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
+;;; longer necessary)
(def!struct (classoid
(:make-load-form-fun classoid-make-load-form-fun)
(:include ctype
(direct-superclasses () :type list)
;; representation of all of the subclasses (direct or indirect) of
;; this class. This is NIL if no subclasses or not initalized yet;
- ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
+ ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
;; subclass layout that was in effect at the time the subclass was
;; created.
(subclasses nil :type (or null hash-table))
- ;; the PCL class object for this class, or NIL if none assigned yet
+ ;; the PCL class (= CL:CLASS, but with a view to future flexibility
+ ;; we don't just call it the CLASS slot) object for this class, or
+ ;; NIL if none assigned yet
(pcl-class nil))
(defun classoid-make-load-form-fun (class)
- (/show "entering %CLASSOID-MAKE-LOAD-FORM-FUN" class)
+ (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
(let ((name (classoid-name class)))
(unless (and name (eq (find-classoid name nil) class))
(/show "anonymous/undefined class case")
(error "can't use anonymous or undefined class as constant:~% ~S"
class))
`(locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
- ;; names which creates fast but non-cold-loadable, non-compact
- ;; code. In this context, we'd rather have compact,
+ ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
+ ;; class names which creates fast but non-cold-loadable,
+ ;; non-compact code. In this context, we'd rather have compact,
;; cold-loadable code. -- WHN 19990928
(declare (notinline find-classoid))
(find-classoid ',name))))
(layout-proper-name layout)
(layout-invalid layout))))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun layout-proper-name (layout)
(classoid-proper-name (layout-classoid layout))))
\f
(make-layout :classoid (or classoid
(make-undefined-classoid name)))))))
-;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH,
+;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
-;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
+;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
;;;
;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
;;; anything about the class", so if LAYOUT is initialized, any
(when (> depth max-depth)
(setf max-depth depth))))
(let* ((new-length (max (1+ max-depth) length))
- (inherits (make-array new-length)))
+ ;; KLUDGE: 0 here is the "uninitialized" element. We need
+ ;; to specify it explicitly for portability purposes, as
+ ;; elements can be read before being set [ see below, "(EQL
+ ;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
+ (inherits (make-array new-length :initial-element 0)))
(dotimes (i length)
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
res
(error "class not yet defined:~% ~S" name))))
(defun (setf find-classoid) (new-value name)
- #-sb-xc (declare (type classoid new-value))
- (ecase (info :type :kind name)
- ((nil))
- (:forthcoming-defclass-type
- ;; XXX Currently, nothing needs to be done in this case. Later, when
- ;; PCL is integrated tighter into SBCL, this might need more work.
- nil)
- (:instance
- #-sb-xc-host ; FIXME
- (let ((old (classoid-of (find-classoid name)))
- (new (classoid-of new-value)))
- (unless (eq old new)
- (warn "changing meta-class of ~S from ~S to ~S"
- name
- (classoid-name old)
- (classoid-name new)))))
- (:primitive
- (error "illegal to redefine standard type ~S" name))
- (:defined
- (warn "redefining DEFTYPE type to be a class: ~S" name)
- (setf (info :type :expander name) nil)))
+ #-sb-xc (declare (type (or null classoid) new-value))
+ (cond
+ ((null new-value)
+ (ecase (info :type :kind name)
+ ((nil))
+ (:defined)
+ (:primitive
+ (error "attempt to redefine :PRIMITIVE type: ~S" name))
+ ((:forthcoming-defclass-type :instance)
+ (setf (info :type :kind name) nil
+ (info :type :classoid name) nil
+ (info :type :documentation name) nil
+ (info :type :compiler-layout name) nil))))
+ (t
+ (ecase (info :type :kind name)
+ ((nil))
+ (:forthcoming-defclass-type
+ ;; XXX Currently, nothing needs to be done in this
+ ;; case. Later, when PCL is integrated tighter into SBCL, this
+ ;; might need more work.
+ nil)
+ (:instance
+ ;; KLUDGE: The reason these clauses aren't directly parallel
+ ;; is that we need to use the internal CLASSOID structure
+ ;; ourselves, because we don't have CLASSes to work with until
+ ;; PCL is built. In the host, CLASSes have an approximately
+ ;; one-to-one correspondence with the target CLASSOIDs (as
+ ;; well as with the target CLASSes, modulo potential
+ ;; differences with respect to conditions).
+ #+sb-xc-host
+ (let ((old (class-of (find-classoid name)))
+ (new (class-of new-value)))
+ (unless (eq old new)
+ (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
+ cross-compiler."
+ name (class-name old) (class-name new))))
+ #-sb-xc-host
+ (let ((old (classoid-of (find-classoid name)))
+ (new (classoid-of new-value)))
+ (unless (eq old new)
+ (warn "changing meta-class of ~S from ~S to ~S"
+ name (classoid-name old) (classoid-name new)))))
+ (:primitive
+ (error "illegal to redefine standard type ~S" name))
+ (:defined
+ (warn "redefining DEFTYPE type to be a class: ~S" name)
+ (setf (info :type :expander name) nil)))
- (remhash name *forward-referenced-layouts*)
- (%note-type-defined name)
- (setf (info :type :kind name) :instance)
- (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
- (unless (eq (info :type :compiler-layout name)
- (classoid-layout new-value))
- (setf (info :type :compiler-layout name) (classoid-layout new-value)))
+ (remhash name *forward-referenced-layouts*)
+ (%note-type-defined name)
+ (setf (info :type :kind name) :instance)
+ (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
+ (unless (eq (info :type :compiler-layout name)
+ (classoid-layout new-value))
+ (setf (info :type :compiler-layout name) (classoid-layout new-value)))))
new-value)
) ; EVAL-WHEN
-
+
;;; Called when we are about to define NAME as a class meeting some
;;; predicate (such as a meta-class type test.) The first result is
;;; always of the desired class. The second result is any existing
projects / sbcl.git / blobdiff