X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=5ccc7ac58e801ce745a7e9ef4efdffe851b2951a;hb=6a8fb906ba96395f2a60f821b2ec7649a2a3ae46;hp=bea6e9090edd4273d567593bb916008296f10f2c;hpb=910e718eb815ef3ecbe82191e8dc4e3728c4e67f;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index bea6e90..5ccc7ac 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -485,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 @@ -700,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 @@ -956,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 @@ -995,170 +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 - :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)) - (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*") @@ -1285,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))