X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=056f8021140d254a8bb6d5b73bb98c29ada8bc33;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=5ccc7ac58e801ce745a7e9ef4efdffe851b2951a;hpb=6a8fb906ba96395f2a60f821b2ec7649a2a3ae46;p=sbcl.git diff --git a/src/code/class.lisp b/src/code/class.lisp index 5ccc7ac..056f802 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -702,13 +702,15 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun find-classoid (name &optional (errorp t) environment) #!+sb-doc - "Return the class with the specified NAME. If ERRORP is false, then NIL is - returned when no such class exists." + "Return the class with the specified NAME. If ERRORP is false, then +NIL is returned when no such class exists." (declare (type symbol name) (ignore environment)) (let ((res (classoid-cell-classoid (find-classoid-cell name)))) (if (or res (not errorp)) res - (error "class not yet defined:~% ~S" name)))) + (error 'simple-type-error + :format-control "class not yet defined:~% ~S" + :format-arguments (list name))))) (defun (setf find-classoid) (new-value name) #-sb-xc (declare (type (or null classoid) new-value)) (cond @@ -871,6 +873,9 @@ (values nil nil) (invoke-complex-subtypep-arg1-method type1 class2 nil t))) +(!define-type-method (classoid :negate) (type) + (make-negation-type :type type)) + (!define-type-method (classoid :unparse) (type) (classoid-proper-name type)) @@ -928,25 +933,32 @@ (setq *built-in-classes* '((t :state :read-only :translation t) - (character :enumerable t :translation base-char) + (character :enumerable t :translation base-char + :prototype-form (code-char 42)) (base-char :enumerable t :inherits (character) - :codes (#.sb!vm:base-char-widetag)) - (symbol :codes (#.sb!vm:symbol-header-widetag)) + :codes (#.sb!vm:base-char-widetag) + :prototype-form (code-char 42)) + (symbol :codes (#.sb!vm:symbol-header-widetag) + :prototype-form '#:mu) (instance :state :read-only) - (system-area-pointer :codes (#.sb!vm:sap-widetag)) - (weak-pointer :codes (#.sb!vm:weak-pointer-widetag)) + (system-area-pointer :codes (#.sb!vm:sap-widetag) + :prototype-form (sb!sys:int-sap 42)) + (weak-pointer :codes (#.sb!vm:weak-pointer-widetag) + :prototype-form (sb!ext:make-weak-pointer (find-package "CL"))) (code-component :codes (#.sb!vm:code-header-widetag)) (lra :codes (#.sb!vm:return-pc-header-widetag)) - (fdefn :codes (#.sb!vm:fdefn-widetag)) + (fdefn :codes (#.sb!vm:fdefn-widetag) + :prototype-form (sb!kernel:make-fdefn "42")) (random-class) ; used for unknown type codes (function :codes (#.sb!vm:closure-header-widetag #.sb!vm:simple-fun-header-widetag) - :state :read-only) + :state :read-only + :prototype-form (function (lambda () 42))) (funcallable-instance :inherits (function) :state :read-only) @@ -955,20 +967,24 @@ (complex :translation complex :inherits (number) - :codes (#.sb!vm:complex-widetag)) + :codes (#.sb!vm:complex-widetag) + :prototype-form (complex 42 42)) (complex-single-float :translation (complex single-float) :inherits (complex number) - :codes (#.sb!vm:complex-single-float-widetag)) + :codes (#.sb!vm:complex-single-float-widetag) + :prototype-form (complex 42f0 42f0)) (complex-double-float :translation (complex double-float) :inherits (complex number) - :codes (#.sb!vm:complex-double-float-widetag)) + :codes (#.sb!vm:complex-double-float-widetag) + :prototype-form (complex 42d0 42d0)) #!+long-float (complex-long-float :translation (complex long-float) :inherits (complex number) - :codes (#.sb!vm:complex-long-float-widetag)) + :codes (#.sb!vm:complex-long-float-widetag) + :prototype-form (complex 42l0 42l0)) (real :translation real :inherits (number)) (float :translation float @@ -976,23 +992,27 @@ (single-float :translation single-float :inherits (float real number) - :codes (#.sb!vm:single-float-widetag)) + :codes (#.sb!vm:single-float-widetag) + :prototype-form 42f0) (double-float :translation double-float :inherits (float real number) - :codes (#.sb!vm:double-float-widetag)) + :codes (#.sb!vm:double-float-widetag) + :prototype-form 42d0) #!+long-float (long-float :translation long-float :inherits (float real number) - :codes (#.sb!vm:long-float-widetag)) + :codes (#.sb!vm:long-float-widetag) + :prototype-form 42l0) (rational :translation rational :inherits (real number)) (ratio :translation (and rational (not integer)) :inherits (rational real number) - :codes (#.sb!vm:ratio-widetag)) + :codes (#.sb!vm:ratio-widetag) + :prototype-form 1/42) (integer :translation integer :inherits (rational real number)) @@ -1000,17 +1020,21 @@ :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)) + :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag) + :prototype-form 42) (bignum :translation (and integer (not fixnum)) :inherits (integer rational real number) - :codes (#.sb!vm:bignum-widetag)) + :codes (#.sb!vm:bignum-widetag) + :prototype-form (expt 2 #.(* sb!vm:n-word-bits (/ 3 2)))) (array :translation array :codes (#.sb!vm:complex-array-widetag) - :hierarchical-p nil) + :hierarchical-p nil + :prototype-form (make-array nil :adjustable t)) (simple-array :translation simple-array :codes (#.sb!vm:simple-array-widetag) - :inherits (array)) + :inherits (array) + :prototype-form (make-array nil)) (sequence :translation (or cons (member nil) vector)) (vector @@ -1020,92 +1044,171 @@ (simple-vector :translation simple-vector :codes (#.sb!vm:simple-vector-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0)) (bit-vector :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag) - :inherits (vector array sequence)) + :inherits (vector array sequence) + :prototype-form (make-array 0 :element-type 'bit :fill-pointer t)) (simple-bit-vector :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag) :direct-superclasses (bit-vector simple-array) :inherits (bit-vector vector simple-array - array sequence)) + array sequence) + :prototype-form (make-array 0 :element-type 'bit)) (simple-array-unsigned-byte-2 :translation (simple-array (unsigned-byte 2) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 2))) (simple-array-unsigned-byte-4 :translation (simple-array (unsigned-byte 4) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 4))) + (simple-array-unsigned-byte-7 + :translation (simple-array (unsigned-byte 7) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-7-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 7))) (simple-array-unsigned-byte-8 :translation (simple-array (unsigned-byte 8) (*)) :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag) :direct-superclasses (vector simple-array) - :inherits (vector simple-array array sequence)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 8))) + (simple-array-unsigned-byte-15 + :translation (simple-array (unsigned-byte 15) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-15-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 15))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 16))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-29 + :translation (simple-array (unsigned-byte 29) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-29-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 29))) + (simple-array-unsigned-byte-31 + :translation (simple-array (unsigned-byte 31) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-31-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 31))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-60 + :translation (simple-array (unsigned-byte 60) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-60-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 60))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-63 + :translation (simple-array (unsigned-byte 63) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-63-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 63))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-unsigned-byte-64 + :translation (simple-array (unsigned-byte 64) (*)) + :codes (#.sb!vm:simple-array-unsigned-byte-64-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(unsigned-byte 64))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 8))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 16))) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 30))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 32))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-signed-byte-61 + :translation (simple-array (signed-byte 61) (*)) + :codes (#.sb!vm:simple-array-signed-byte-61-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 61))) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + (simple-array-signed-byte-64 + :translation (simple-array (signed-byte 64) (*)) + :codes (#.sb!vm:simple-array-signed-byte-64-widetag) + :direct-superclasses (vector simple-array) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(signed-byte 64))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'single-float)) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'double-float)) #!+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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type 'long-float)) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(complex single-float))) (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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(complex double-float))) #!+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)) + :inherits (vector simple-array array sequence) + :prototype-form (make-array 0 :element-type '(complex long-float))) (string :translation string :direct-superclasses (vector) @@ -1115,43 +1218,50 @@ :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)) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'nil :fill-pointer t)) (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)) + :inherits (vector-nil simple-string string vector simple-array + array sequence) + :prototype-form (make-array 0 :element-type 'nil)) (base-string :translation base-string :codes (#.sb!vm:complex-base-string-widetag) :direct-superclasses (string) - :inherits (string vector array sequence)) + :inherits (string vector array sequence) + :prototype-form (make-array 0 :element-type 'base-char :fill-pointer t)) (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)) + array sequence) + :prototype-form (make-array 0 :element-type 'base-char)) (list :translation (or cons (member nil)) :inherits (sequence)) (cons :codes (#.sb!vm:list-pointer-lowtag) :translation cons - :inherits (list sequence)) + :inherits (list sequence) + :prototype-form (cons nil nil)) (null :translation (member nil) :inherits (symbol list sequence) - :direct-superclasses (symbol list)) + :direct-superclasses (symbol list) + :prototype-form 'nil) (stream :state :read-only :depth 3 - :inherits (instance))))) + :inherits (instance) + :prototype-form (make-broadcast-stream))))) ;;; See also src/code/class-init.lisp where we finish setting up the ;;; translations for built-in types. @@ -1166,12 +1276,13 @@ enumerable state depth + prototype-form (hierarchical-p t) ; might be modified below (direct-superclasses (if inherits (list (car inherits)) '(t)))) x - (declare (ignore codes state translation)) + (declare (ignore codes state translation prototype-form)) (let ((inherits-list (if (eq name t) () (cons t (reverse inherits)))) @@ -1307,11 +1418,6 @@ name layout)))))) -;;; a vector that maps type codes to layouts, used for quickly finding -;;; the layouts of built-in classes -(defvar *built-in-class-codes*) ; initialized in cold load -(declaim (type simple-vector *built-in-class-codes*)) - (!cold-init-forms #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*") (setq *built-in-class-codes*