X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=5ccc7ac58e801ce745a7e9ef4efdffe851b2951a;hb=6a8fb906ba96395f2a60f821b2ec7649a2a3ae46;hp=9258e585de711ded40018bd270b7ca427dfef80d;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 9258e58..5ccc7ac 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -1,7 +1,6 @@
 ;;;; 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.
@@ -16,10 +15,13 @@
 
 (!begin-collecting-cold-init-forms)
 
-;;;; 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
@@ -53,24 +55,26 @@
   (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))))
@@ -207,7 +211,7 @@
 	    (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))))
 
@@ -265,9 +269,9 @@
 	      (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
@@ -481,19 +485,18 @@
 	(setf (layout-invalid layout) nil
 	      (classoid-layout classoid) layout))
 
-    (let ((inherits (layout-inherits layout)))
-      (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
-	(let* ((super (layout-classoid (svref inherits i)))
-	       (subclasses (or (classoid-subclasses super)
-			       (setf (classoid-subclasses super)
-				     (make-hash-table :test 'eq)))))
-	  (when (and (eq (classoid-state super) :sealed)
-		     (not (gethash classoid subclasses)))
-	    (warn "unsealing sealed class ~S in order to subclass it"
-		  (classoid-name super))
-	    (setf (classoid-state super) :read-only))
-	  (setf (gethash classoid subclasses)
-		(or destruct-layout layout))))))
+    (dovector (super-layout (layout-inherits layout))
+      (let* ((super (layout-classoid super-layout))
+             (subclasses (or (classoid-subclasses super)
+                             (setf (classoid-subclasses super)
+                                   (make-hash-table :test 'eq)))))
+        (when (and (eq (classoid-state super) :sealed)
+                   (not (gethash classoid subclasses)))
+          (warn "unsealing sealed class ~S in order to subclass it"
+                (classoid-name super))
+          (setf (classoid-state super) :read-only))
+        (setf (gethash classoid subclasses)
+              (or destruct-layout layout)))))
 
   (values))
 ); EVAL-WHEN
@@ -517,7 +520,11 @@
 	(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)))
@@ -692,10 +699,6 @@
       (setf (info :type :classoid name)
 	    (make-classoid-cell name))))
 
-;;; FIXME: When the system is stable, this DECLAIM FTYPE should
-;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
-(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv)))
-		find-classoid))
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 (defun find-classoid (name &optional (errorp t) environment)
   #!+sb-doc
@@ -707,38 +710,64 @@
 	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
@@ -922,6 +951,61 @@
       :inherits (function)
       :state :read-only)
 
+     (number :translation number)
+     (complex
+      :translation complex
+      :inherits (number)
+      :codes (#.sb!vm:complex-widetag))
+     (complex-single-float
+      :translation (complex single-float)
+      :inherits (complex number)
+      :codes (#.sb!vm:complex-single-float-widetag))
+     (complex-double-float
+      :translation (complex double-float)
+      :inherits (complex number)
+      :codes (#.sb!vm:complex-double-float-widetag))
+     #!+long-float
+     (complex-long-float
+      :translation (complex long-float)
+      :inherits (complex number)
+      :codes (#.sb!vm:complex-long-float-widetag))
+     (real :translation real :inherits (number))
+     (float
+      :translation float
+      :inherits (real number))
+     (single-float
+      :translation single-float
+      :inherits (float real number)
+      :codes (#.sb!vm:single-float-widetag))
+     (double-float
+      :translation double-float
+      :inherits (float real number)
+      :codes (#.sb!vm:double-float-widetag))
+     #!+long-float
+     (long-float
+      :translation long-float
+      :inherits (float real number)
+      :codes (#.sb!vm:long-float-widetag))
+     (rational
+      :translation rational
+      :inherits (real number))
+     (ratio
+      :translation (and rational (not integer))
+      :inherits (rational real number)
+      :codes (#.sb!vm:ratio-widetag))
+     (integer
+      :translation integer
+      :inherits (rational real number))
+     (fixnum
+      :translation (integer #.sb!xc:most-negative-fixnum
+		    #.sb!xc:most-positive-fixnum)
+      :inherits (integer rational real number)
+      :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
+     (bignum
+      :translation (and integer (not fixnum))
+      :inherits (integer rational real number)
+      :codes (#.sb!vm:bignum-widetag))
+
      (array :translation array :codes (#.sb!vm:complex-array-widetag)
             :hierarchical-p nil)
      (simple-array
@@ -961,151 +1045,116 @@
       :direct-superclasses (vector simple-array)
       :inherits (vector simple-array array sequence))
      (simple-array-unsigned-byte-16
-     :translation (simple-array (unsigned-byte 16) (*))
-     :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array (unsigned-byte 16) (*))
+      :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-unsigned-byte-32
-     :translation (simple-array (unsigned-byte 32) (*))
-     :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array (unsigned-byte 32) (*))
+      :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-8
-     :translation (simple-array (signed-byte 8) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array (signed-byte 8) (*))
+      :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-16
-     :translation (simple-array (signed-byte 16) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array (signed-byte 16) (*))
+      :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-30
-     :translation (simple-array (signed-byte 30) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array (signed-byte 30) (*))
+      :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-32
-     :translation (simple-array (signed-byte 32) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array (signed-byte 32) (*))
+      :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-single-float
-     :translation (simple-array single-float (*))
-     :codes (#.sb!vm:simple-array-single-float-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
+      :translation (simple-array single-float (*))
+      :codes (#.sb!vm:simple-array-single-float-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
      (simple-array-double-float
-     :translation (simple-array double-float (*))
-     :codes (#.sb!vm:simple-array-double-float-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
-    #!+long-float
-    (simple-array-long-float
-     :translation (simple-array long-float (*))
-     :codes (#.sb!vm:simple-array-long-float-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
-    (simple-array-complex-single-float
-     :translation (simple-array (complex single-float) (*))
-     :codes (#.sb!vm:simple-array-complex-single-float-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
-    (simple-array-complex-double-float
-     :translation (simple-array (complex double-float) (*))
-     :codes (#.sb!vm:simple-array-complex-double-float-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
-    #!+long-float
-    (simple-array-complex-long-float
-     :translation (simple-array (complex long-float) (*))
-     :codes (#.sb!vm:simple-array-complex-long-float-widetag)
-     :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence))
-    (string
-     :translation string
-     :codes (#.sb!vm:complex-string-widetag)
-     :direct-superclasses (vector)
-     :inherits (vector array sequence))
-    (simple-string
-     :translation simple-string
-     :codes (#.sb!vm:simple-string-widetag)
-     :direct-superclasses (string simple-array)
-     :inherits (string vector simple-array
-		array sequence))
-    (list
-     :translation (or cons (member nil))
-     :inherits (sequence))
-    (cons
-     :codes (#.sb!vm:list-pointer-lowtag)
-     :translation cons
-     :inherits (list sequence))
-    (null
-     :translation (member nil)
-     :inherits (symbol list sequence)
-     :direct-superclasses (symbol list))
-    (number :translation number)
-    (complex
-     :translation complex
-     :inherits (number)
-     :codes (#.sb!vm:complex-widetag))
-    (complex-single-float
-     :translation (complex single-float)
-     :inherits (complex number)
-     :codes (#.sb!vm:complex-single-float-widetag))
-    (complex-double-float
-     :translation (complex double-float)
-     :inherits (complex number)
-     :codes (#.sb!vm:complex-double-float-widetag))
-    #!+long-float
-    (complex-long-float
-     :translation (complex long-float)
-     :inherits (complex number)
-     :codes (#.sb!vm:complex-long-float-widetag))
-    (real :translation real :inherits (number))
-    (float
-     :translation float
-     :inherits (real number))
-    (single-float
-     :translation single-float
-     :inherits (float real number)
-     :codes (#.sb!vm:single-float-widetag))
-    (double-float
-     :translation double-float
-     :inherits (float real number)
-     :codes (#.sb!vm:double-float-widetag))
-    #!+long-float
-    (long-float
-     :translation long-float
-     :inherits (float real number)
-     :codes (#.sb!vm:long-float-widetag))
-    (rational
-     :translation rational
-     :inherits (real number))
-    (ratio
-     :translation (and rational (not integer))
-     :inherits (rational real number)
-     :codes (#.sb!vm:ratio-widetag))
-    (integer
-     :translation integer
-     :inherits (rational real number))
-    (fixnum
-     :translation (integer #.sb!xc:most-negative-fixnum
-			   #.sb!xc:most-positive-fixnum)
-     :inherits (integer rational real number)
-     :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
-    (bignum
-     :translation (and integer (not fixnum))
-     :inherits (integer rational real number)
-     :codes (#.sb!vm:bignum-widetag))
-    (stream
-     :state :read-only
-     :depth 3
-     :inherits (instance)))))
+      :translation (simple-array double-float (*))
+      :codes (#.sb!vm:simple-array-double-float-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
+     #!+long-float
+     (simple-array-long-float
+      :translation (simple-array long-float (*))
+      :codes (#.sb!vm:simple-array-long-float-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
+     (simple-array-complex-single-float
+      :translation (simple-array (complex single-float) (*))
+      :codes (#.sb!vm:simple-array-complex-single-float-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
+     (simple-array-complex-double-float
+      :translation (simple-array (complex double-float) (*))
+      :codes (#.sb!vm:simple-array-complex-double-float-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
+     #!+long-float
+     (simple-array-complex-long-float
+      :translation (simple-array (complex long-float) (*))
+      :codes (#.sb!vm:simple-array-complex-long-float-widetag)
+      :direct-superclasses (vector simple-array)
+      :inherits (vector simple-array array sequence))
+     (string
+      :translation string
+      :direct-superclasses (vector)
+      :inherits (vector array sequence))
+     (simple-string
+      :translation simple-string
+      :direct-superclasses (string simple-array)
+      :inherits (string vector simple-array array sequence))
+     (vector-nil
+      ;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))?
+      :translation (vector nil)
+      :codes (#.sb!vm:complex-vector-nil-widetag)
+      :direct-superclasses (string)
+      :inherits (string vector array sequence))
+     (simple-array-nil
+      :translation (simple-array nil (*))
+      :codes (#.sb!vm:simple-array-nil-widetag)
+      :direct-superclasses (vector-nil simple-string)
+      :inherits (vector-nil simple-string string vector simple-array array sequence))
+     (base-string
+      :translation base-string
+      :codes (#.sb!vm:complex-base-string-widetag)
+      :direct-superclasses (string)
+      :inherits (string vector array sequence))
+     (simple-base-string
+      :translation simple-base-string
+      :codes (#.sb!vm:simple-base-string-widetag)
+      :direct-superclasses (base-string simple-string)
+      :inherits (base-string simple-string string vector simple-array
+		 array sequence))
+     (list
+      :translation (or cons (member nil))
+      :inherits (sequence))
+     (cons
+      :codes (#.sb!vm:list-pointer-lowtag)
+      :translation cons
+      :inherits (list sequence))
+     (null
+      :translation (member nil)
+      :inherits (symbol list sequence)
+      :direct-superclasses (symbol list))
+     
+     (stream
+      :state :read-only
+      :depth 3
+      :inherits (instance)))))
 
-;;; comment from CMU CL:
-;;;   See also type-init.lisp where we finish setting up the
-;;;   translations for built-in types.
+;;; See also src/code/class-init.lisp where we finish setting up the
+;;; translations for built-in types.
 (!cold-init-forms
   (dolist (x *built-in-classes*)
     #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
@@ -1232,9 +1281,8 @@
   (let ((inherits (layout-inherits layout))
 	(classoid (layout-classoid layout)))
     (modify-classoid classoid)
-    (dotimes (i (length inherits)) ; FIXME: DOVECTOR
-      (let* ((super (svref inherits i))
-	     (subs (classoid-subclasses (layout-classoid super))))
+    (dovector (super inherits)
+      (let ((subs (classoid-subclasses (layout-classoid super))))
 	(when subs
 	  (remhash classoid subs)))))
   (values))