From 39aaad6627c5110bfc250a63c6e72b648746c913 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 4 Feb 1993 22:34:56 +0000 Subject: [PATCH] *** empty log message *** --- code/class.lisp | 505 ++++++++++++++++++++++++++++++------------------ 1 file changed, 313 insertions(+), 192 deletions(-) diff --git a/code/class.lisp b/code/class.lisp index 6baea15ce..4d1f20cff 100644 --- a/code/class.lisp +++ b/code/class.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.1 1993/01/15 15:26:33 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.2 1993/02/04 22:34:56 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -20,21 +20,32 @@ (export '(layout layout-hash layout-hash-length layout-class layout-invalid layout-inherits layout-inheritance-depth layout-length + layout-info + layout-of structure-class-p structure-class-print-function - structure-class-make-load-form-fun find-layout)) + structure-class-make-load-form-fun find-layout + class-proper-name class-layout class-state class-subclasses + class-init)) (in-package "LISP") -(export '(class structure-class class-name find-class)) +(export '(class structure-class class-name find-class class-of built-in-class)) (in-package "KERNEL") +(with-cold-load-init-forms) + ;;; Table mapping class names to layouts for classes we have referenced but not -;;; yet loaded. -;;; -;;; ### Initialize to list of all layouts created by genesis. Removed when we -;;; actually see the definition in top-level code. -;;; -(defvar *forward-referenced-layouts* (make-hash-table :test #'equal)) +;;; yet loaded. This is initialized from an ALIST created by Genesis +;;; describing the layouts it created at cold-load time. +;;; +(defvar *forward-referenced-layouts*) +(cold-load-init + (setq *forward-referenced-layouts* (make-hash-table :test #'equal)) +#-ns-boot + (dolist (x lisp::*initial-layouts*) + (setf (gethash (car x) *forward-referenced-layouts*) (cdr x))) +#-ns-boot + (makunbound 'lisp::*initial-layouts*)) ;;;; Class definition structures: @@ -55,7 +66,12 @@ ;;; are used to create the LAYOUT if it doesn't exist yet (other slots left ;;; unitialized.) ;;; -(defstruct (layout (:print-function %print-layout) +(defstruct (layout (:print-function + (lambda (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :identity t) + (format stream "Layout for ~S~@[, Invalid=~S~]" + (layout-class s) (layout-invalid s))))) (:make-load-form-fun :ignore-it)) ;; ;; Some hash bits for this layout. Sleazily accessed via STRUCTURE-REF, see @@ -105,6 +121,7 @@ ;;; (defstruct (class (:make-load-form-fun class-make-load-form-fun) + (:print-function %print-class) (:include ctype (:class-info (type-class-or-lose 'class)))) ;; @@ -128,10 +145,16 @@ (defun class-make-load-form-fun (class) (let ((name (class-name class))) (unless (and name (eq (find-class name nil) class)) - (compiler-error + (error "Can't use anonymous or undefined class as constant:~% ~S" class)) `(find-class ',name))) +;;; +(defun %print-class (s stream d) + (declare (ignore d)) + (print-unreadable-object (s stream :identity t :type t) + (format stream "~:[<anonymous>~;~:*~S~]~@[ (~(~A~))~]" + (class-name s) (class-state s)))) ;;; The UNDEFINED-CLASS is a cookie we make up to stick in forward referenced @@ -144,20 +167,20 @@ ;;; BUILT-IN-CLASS is used to represent the standard classes that aren't ;;; defined with DEFSTRUCT and other specially implemented primitve types whose -;;; only attribute is their name. Some standard classes are +;;; only attribute is their name. ;;; -(defstruct (built-in-class - (:include class)) - ;; - ;; Translation of this class to some other composite type (usually a union of - ;; other classes.) This translation is done when type specifiers are parsed. - ;; Internally we should never encounter translated classes, only their - ;; translation. If NIL, then this class stands on its own. - (translation nil :type (or ctype null)) +;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they are +;;; effectively DEFTYPE'd to some other type (usually a union of other classes +;;; or a "primitive" type such as NUMBER, ARRAY, etc.) This translation is +;;; done when type specifiers are parsed. Type system operations (union, +;;; subtypep, etc.) should never encounter translated classes, only their +;;; translation. +;;; +(defstruct (built-in-class (:include class)) ;; - ;; List of names of type-classes which are subtypes of this class. This is - ;; mutually exclusive with TRANSLATION. - (type-classes nil :type list)) + ;; Type we translate to on parsing. If NIL, then this class stands on its + ;; own. Only :INITIALIZING during for a period during cold-load. See below. + (translation nil :type (or ctype (member nil :initializing)))) ;;; STRUCTURE-CLASS represents what we need to know about structure classes. @@ -182,6 +205,29 @@ ;;;; Class namespace: + +#+ns-boot +(defun find-structure-class (name) + (let ((info (info type structure-info name))) + (when info + (let* ((res (setf (info type class name) + (make-structure-class :name name))) + (includes (c::dd-includes info)) + (super (find-class + (if includes + (first includes) + 'structure-object))) + (super-layout (class-layout super)) + (layout + (find-layout name (c::dd-length info) + (concatenate 'vector + (layout-inherits super-layout) + (vector super-layout)) + (1+ (layout-inheritance-depth super-layout))))) + (register-layout layout nil nil) + (setf (info type compiler-layout name) layout) + res)))) + ;;; FIND-CLASS -- Public ;;; @@ -189,7 +235,11 @@ "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 (info type class name))) + (let ((res #-ns-boot + (info type class name) + #+ns-boot + (or (info type class name) + (find-structure-class name)))) (if (or res (not errorp)) res (error "Class not yet defined:~% ~S" name)))) @@ -197,22 +247,22 @@ (defun (setf find-class) (new-value name) (ecase (info type kind name) (nil) - (:structure + (#+ns-boot (:instance :structure) #-ns-boot :instance (let ((old (class-of (info type class name))) (new (class-of new-value))) (unless (eq old new) - (compiler-warning "Changing meta-class of ~S from ~S to ~S." - name (class-name old) (class-name new))))) + (warn "Changing meta-class of ~S from ~S to ~S." + name (class-name old) (class-name new))))) (:primitive - (compiler-error "Illegal to redefine standard type ~S." name)) + (error "Illegal to redefine standard type ~S." name)) (:defined - (compiler-warning "Redefining DEFTYPE type to be a class: ~S." - name) + (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) :structure) + (setf (info type kind name) :instance) (setf (info type class name) new-value)) @@ -223,8 +273,7 @@ ;;; result is any existing layout for this name. ;;; (defun insured-find-class (name meta-class constructor) - (let* ((name (dd-name info)) - (old (info type class name)) + (let* ((old (find-class name nil)) (res (if (and old (eq (class-of old) meta-class)) old (funcall constructor :name name))) @@ -235,18 +284,36 @@ (values res found))) + +;;; CLASS-PROPER-NAME -- Exported +;;; +;;; If the class has a proper name, return the name, otherwise return +;;; the class. +;;; +(defun class-proper-name (class) + (let ((name (class-name class))) + (if (and name (eq (find-class name) class)) + name + class))) + -;;;; Class type operations: +;;;; CLASS type operations: (define-type-class class) -(define-type-method (instance :simple-subtypep) (class1 class2) - (if (eq class1 class2) - (values t t) - (let ((subclasses (class-subclasses class2))) - (if (and subclasses (gethash class1 subclasses)) - (values t t) - (values nil t))))) +;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two +;;; classes are equal, since there are EQ checks in those operations. +;;; +(define-type-method (class :simple-=) (type1 type2) + (assert (not (eq type1 type2))) + (values nil t)) + +(define-type-method (class :simple-subtypep) (class1 class2) + (assert (not (eq class1 class2))) + (let ((subclasses (class-subclasses class2))) + (if (and subclasses (gethash class1 subclasses)) + (values t t) + (values nil t)))) ;;; SEALED-CLASS-INTERSECTION -- Internal @@ -263,7 +330,7 @@ (do-hash (subclass layout s-sub) (declare (ignore layout)) (when (gethash subclass o-sub) - (res (specifier-type class)))) + (res (specifier-type subclass)))) (values (res) t)) (values *empty-type* t)))) @@ -273,15 +340,15 @@ ;;; classes, since a subclass of both might be defined. If either class is ;;; sealed, we can eliminate this possibility. ;;; -(define-type-method (instance :simple-intersection) (class1 class2) +(define-type-method (class :simple-intersection) (class1 class2) (declare (type class class1 class2)) - (cond ((eq class1 class2) type1) + (cond ((eq class1 class2) class1) ((let ((subclasses (class-subclasses class2))) (and subclasses (gethash class1 subclasses))) - (values type1 t)) + (values class1 t)) ((let ((subclasses (class-subclasses class1))) (and subclasses (gethash class2 subclasses))) - (values type2 t)) + (values class2 t)) ((or (structure-class-p class1) (structure-class-p class2)) (values *empty-type* t)) @@ -290,21 +357,186 @@ ((eq (class-state class2) :sealed) (sealed-class-intersection class2 class1)) (t - (values type1 nil)))) - - -(define-type-method (instance :complex-subtypep-arg2) (type1 type2) - (declare (type instance-type type2)) - (values (or (eq type1 *wild-type*) - (and (eq (type-class-name (type-class-info type1)) 'alien) - (eq (class-name type2) 'alien-value))) - t)) + (values class1 nil)))) -(define-type-method (instance :unparse) (type) +(define-type-method (class :unparse) (type) (class-proper-name type)) -(define-type-method (instance :simple-=) (type1 type2) - (values (eq type1 type2) t)) + +;;;; Built-in classes & class-of: + +(defvar built-in-classes) +(cold-load-init + (setq built-in-classes + '((t :state :read-only) + (character :enumerable t :codes (#.vm:base-char-type)) + + (array :translation array + :codes + (#.vm:complex-array-type + #.vm:simple-array-type + #.vm:simple-array-double-float-type + #.vm:simple-array-single-float-type + #.vm:simple-array-unsigned-byte-2-type + #.vm:simple-array-unsigned-byte-4-type + #.vm:simple-array-unsigned-byte-8-type + #.vm:simple-array-unsigned-byte-16-type + #.vm:simple-array-unsigned-byte-32-type)) + (sequence :translation (or cons (member nil) vector)) + (symbol :codes (#.vm:symbol-header-type)) + + (instance :state :read-only) + #+ns-boot + (structure-object :state :read-only :inherits (instance)) + + (system-area-pointer) + (weak-pointer) + (scavenger-hook) + (code-component) + (lra) + (fdefn) + (random-class) ; Used for unknown type codes. + + (function + :codes + (#.vm:byte-code-closure-type + #.vm:byte-code-function-type + #.vm:closure-header-type #.vm:function-header-type) + :state :read-only) + (generic-function :inherits (function) :state :read-only + :codes (#.vm:funcallable-instance-header-type)) + + (vector :translation vector :inherits (array sequence) + :hierarchical nil + :codes (#.vm:complex-vector-type #.vm:simple-vector-type)) + (bit-vector + :translation bit-vector :inherits (vector array sequence) + :hierarchical nil + :codes (#.vm:complex-bit-vector-type #.vm:simple-bit-vector-type)) + (string + :translation string :inherits (vector array sequence) + :hierarchical nil + :codes (#.vm:complex-string-type #.vm:simple-string-type)) + + (number :translation number) + (complex :translation complex :inherits (number) + :codes (#.vm:complex-type)) + (float :translation float :inherits (number)) + (single-float + :translation single-float :inherits (float number) + :codes (#.vm:single-float-type)) + (double-float + :translation double-float :inherits (float number) + :codes (#.vm:double-float-type)) + (rational :translation rational :inherits (number)) + (ratio + :translation (and rational (not integer)) + :inherits (rational number) + :codes (#.vm:ratio-type)) + (integer + :translation integer :inherits (rational number)) + (fixnum + :translation (integer #.vm:target-most-negative-fixnum + #.vm:target-most-positive-fixnum) + :inherits (integer rational number) + :codes (#.vm:even-fixnum-type #.vm:odd-fixnum-type)) + (bignum + :translation (and integer (not fixnum)) + :inherits (integer rational number) + :codes (#.vm:bignum-type)) + + (list :translation (or cons (member nil)) :inherits (sequence)) + (cons :inherits (list sequence) :codes (#.vm:list-pointer-type)) + (null :translation (member nil) :inherits (symbol list sequence) + :hierarchical nil)))) + +;;; See also type-init.lisp where we finish setting up the translations for +;;; built-in types. +;;; +(cold-load-init + (dolist (x built-in-classes) + (destructuring-bind (name &key (translation nil trans-p) inherits codes + enumerable state (hierarchical t)) + x + (declare (ignore codes state translation)) + (let ((class (make-built-in-class + :enumerable enumerable + :name name + :translation (if trans-p :initializing nil)))) + (setf (info type kind name) :primitive) + (setf (info type class name) class) + (unless trans-p + (setf (info type builtin name) class)) + (register-layout + (find-layout name 0 + (map 'vector + #'(lambda (x) + (class-layout (find-class x))) + (if (eq name 't) + () + (cons 't (reverse inherits)))) + (if hierarchical (1+ (length inherits)) -1)) + nil nil))))) + + +;;; Now that we have set up the class heterarchy, seal the sealed classes. +;;; This must be done after the subclasses have been set up. +;;; +(cold-load-init + (dolist (x built-in-classes) + (destructuring-bind (name &key (state :sealed) &allow-other-keys) x + (setf (class-state (find-class name)) state)))) + + +;;; A vector that maps type codes to layouts, used for quickly finding the +;;; layouts of built-in classes. +;;; +(defvar built-in-class-codes) +(cold-load-init + (setq built-in-class-codes + (let ((res (make-array 256 :initial-element + (class-layout (find-class 'random-class))))) + (dolist (x built-in-classes res) + (destructuring-bind (name &key codes &allow-other-keys) + x + (let ((layout (class-layout (find-class name)))) + (dolist (code codes) + (setf (svref res code) layout)))))))) + + +;;; LAYOUT-OF -- Exported +;;; +;;; Return the layout for an object. This is the basic operation for +;;; finding out the "type" of an object, and is used for generic function +;;; dispatch. The standard doesn't seem to say as much as it should about what +;;; this returns for built-in objects. For example, it seems that we must +;;; return NULL rather than LIST when X is NIL so that GF's can specialize on +;;; NULL. +;;; +;;; ### special-case funcallable-instance +;;; +#-ns-boot +(declaim (inline layout-of)) +(defun layout-of (x) + (cond #-ns-boot + ((%instancep x) (%instance-layout x)) + #+ns-boot + ((structurep x) + (class-layout (find-class (structure-ref x 0)))) + #-ns-boot + ((null x) '#.(class-layout (find-class 'null))) + #+ns-boot + ((null x) (class-layout (find-class 'null))) + (t (svref built-in-class-codes (get-type x))))) + + +;;; CLASS-OF -- Public +;;; +(declaim (inline class-of)) +(defun class-of (object) + "Return the class of the supplied object, which may be any Lisp object, not + just a CLOS STANDARD-OBJECT." + (layout-class (layout-of object))) ;;;; Class definition/redefinition: @@ -358,18 +590,19 @@ (setf (class-subclasses class) nil))) (cond (destruct-p - (setf (layout-invalid class-layout) (layout-invalid layout)) + (setf (layout-invalid class-layout) nil) (setf (layout-inherits class-layout) (layout-inherits layout)) (setf (layout-inheritance-depth class-layout) (layout-inheritance-depth layout)) (setf (layout-length class-layout) (layout-length layout)) (setf (layout-info class-layout) (layout-info layout))) (t + (setf (layout-invalid layout) nil) (setf (class-layout class) layout))) (let ((inherits (layout-inherits layout))) (dotimes (i (length inherits)) - (let* ((super (svref inherits i)) + (let* ((super (layout-class (svref inherits i))) (subclasses (or (class-subclasses super) (setf (class-subclasses super) (make-hash-table :test #'eq))))) @@ -386,17 +619,8 @@ ;;; LAYOUT-PROPER-NAME -- Internal ;;; -;;; Return something we can print to unambiguously describe the class for a -;;; layout. If the class has a proper name, return the name, otherwise return -;;; the class. -;;; -(defun layout-name (x) - (let* ((class (layout-class x)) - (name (class-name class))) - (if (and name (eq (find-class name) class)) - name - class))) - +(defun layout-proper-name (layout) + (class-proper-name (layout-class layout))) ;;; REDEFINE-LAYOUT-WARNING -- Interface ;;; @@ -404,12 +628,12 @@ ;;; warning and return T. ;;; (defun redefine-layout-warning (old old-context new new-context) - (assert (eq (layout-class old) (layout-class new) class)) + (assert (eq (layout-class old) (layout-class new))) (let ((name (layout-proper-name old))) (or (let ((oldi (layout-inherits old)) (newi (layout-inherits new))) (or (when (mismatch oldi newi :key #'layout-proper-name) - (compiler-warning + (warn "Change in superclasses of class ~S:~@ ~ ~A superclasses: ~S~% ~ ~A superclasses: ~S" @@ -419,28 +643,28 @@ t) (let ((diff (mismatch oldi newi))) (when diff - (compiler-warning + (warn "In class ~S:~% ~ ~A definition of superclass ~S incompatible with ~ ~A definition." - name old-context (layout-name (svref oldi diff)) + name old-context (layout-proper-name (svref oldi diff)) new-context) t)))) (let ((old-len (layout-length old)) (new-len (layout-length new))) (unless (= old-len new-len) - (compiler-warning "Change in instance length of class ~S:~% ~ - ~A length: ~D~% ~ - ~A length: ~D" - name - old-context old-len - new-context new-len) + (warn "Change in instance length of class ~S:~% ~ + ~A length: ~D~% ~ + ~A length: ~D" + name + old-context old-len + new-context new-len) t)) (when (/= (layout-inheritance-depth old) (layout-inheritance-depth new)) - (compiler-warning "Change in the inheritance structure of class ~S~@ - between the ~A definition and the ~A definition." - name old-context new-context) + (warn "Change in the inheritance structure of class ~S~@ + between the ~A definition and the ~A definition." + name old-context new-context) t)))) @@ -458,7 +682,7 @@ ;;; incompatible, we allow the layout to be replaced, altered or left alone. ;;; (defun find-layout (name length inherits depth) - (let* ((class (or (info type class name) + (let* ((class (or (find-class name nil) (make-undefined-class name))) (old (or (class-layout class) (gethash name *forward-referenced-layouts*))) @@ -485,8 +709,8 @@ (warn "Any old ~S instances will be in a bad way.~@ I hope you know what you're doing..." name) - (setf (layout-inherits-depth old) depth) - (setf (layout-inheritance-depth old) inherits) + (setf (layout-inherits old) inherits) + (setf (layout-inheritance-depth old) depth) (setf (layout-length old) length) old) (use-current () @@ -499,109 +723,6 @@ (t old)))) -;;;; Built-in classes: - -;;; ### If any of these layouts are referenced as constants in the cold load, -;;; then genesis must pre-intern the layouts, and we would actually create the -;;; classes here. Probably needs to be an init-function that runs before -;;; top-level forms. - -;;; ### special-case instance, funcallable-instance, null for LAYOUT-OF -;;; -(defconstant built-in-classes - '((t :subclasses (number array member function structure alien)) - (character :enumerable t) - (base-char :inherits (character) :codes (#.vm:base-char-type) - :enumerable t) - (extended-char :inherits (character) :translation nil :enumerable t) - (standard-char :inherits (base-char character) :enumerable t) - - (array :tranlation array - :codes - (#.vm:complex-array-type - #.vm:simple-array-type - #.vm:simple-array-double-float-type - #.vm:simple-array-single-float-type - #.vm:simple-array-unsigned-byte-2-type - #.vm:simple-array-unsigned-byte-4-type - #.vm:simple-array-unsigned-byte-8-type - #.vm:simple-array-unsigned-byte-16-type - #.vm:simple-array-unsigned-byte-32-type)) - (sequence :translation (or cons (member nil) vector)) - (symbol :codes (#.vm:symbol-header-type)) - (keyword :inherits (symbol)) - (system-area-pointer) - (weak-pointer) - (scavenger-hook) - (code-component) - (lra) - (fdefn) - - (function - :codes - (#.vm:byte-code-closure-type #.vm:byte-code-function-type - #.vm:closure-header-type #.vm:function-header-type) - :subclasses (function)) - (generic-function :inherits (function) - :subclasses (function) - :codes (#.vm:funcallable-instance-header-type)) - - (vector :translation vector :inherits (array sequence) - :codes (#.vm:complex-vector-type #.vm:simple-vector-type)) - (bit-vector - :translation bit-vector :inherits (vector array sequence) - :codes (#.vm:complex-bit-vector-type #.vm:simple-bit-vector-type)) - (string - :translation string :inherits (vector array sequence) - :codes (#.vm:complex-string-type #.vm:simple-string-type)) - - (number :translation number) - (complex :translation complex :inherits (number) - :codes (#.vm:complex-type)) - (float :translation float :inherits (number)) - (single-float - :translation single-float :inherits (float number) - :codes (#.vm:single-float-type)) - (double-float - :translation double-float :inherits (float number) - :codes (#.vm:double-float-type)) - (rational :translation rational :inherits (number)) - (ratio - :translation (and rational (not integer)) - :inherits (rational number) - :codes (#.vm:ratio-type)) - (integer - :translation integer :inherits (rational number) - :codes (#.vm:bignum-type #.vm:even-fixnum-type #.vm:odd-fixnum-type)) - - (list :translation (or cons (member nil)) :inherits (sequence)) - (cons :inherits (list sequence) :codes (#.vm:list-type)) - (null :translation (member nil) :inherits (symbol list sequence)))) - -(dolist (x built-in-classes) - (let* ((name (first x)) - (class (make-built-in-class name (specifier-type name))) - (layout (make-layout - :class class - :inherits (map 'vector #'find-layout (reverse (rest x)))))) - (register-layout layout nil nil) - (setf (info type class name) class))) - -(dolist (x built-in-classes) - (setf (class-state (find-class (first x))) :frozen)) - -(defconstant built-in-class-codes - (let ((res (make-array 256 :initial-element nil))) - (dolist (x built-in-classes) - (let ((layout (class-layout (find-class (first x))))) - (dolist (code (third x)) - (setf (svref res code) layout)))))) - -(defun layout-of (x) - (cond ((%instancep x) (%instance-layout x)) - ((null x) (load-time-value (class-layout (find-class 'null)))) - ((svref built-in-class-codes (vm:get-type x))) - (t - (error "Some strange object: ~S" x)))) +;;;; Cold loading initializations. -(defun class-of (x) (class-layout (layout-of x))) +(emit-cold-load-defuns "CLASS") -- GitLab