diff --git a/code/class.lisp b/code/class.lisp index 627dc8acf40235eeff0a62b3074d50e8f7379d08..034d2634c692383e6e24c346805c96523912d9e4 100644 --- a/code/class.lisp +++ b/code/class.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.43 2000/05/02 04:44:03 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.44 2000/08/06 19:12:17 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -174,6 +174,51 @@ (1+ (random layout-hash-max seed))))) layout) +;;; order-layout-inherits -- Interface +;;; +;;; Arrange the inherited layouts to appear at their expected depth, ensuring +;;; that hierarchical type tests succeed. Layouts with a specific depth are +;;; placed first, then the non-hierarchical layouts fill remaining elements. +;;; Any empty elements are filled with layout copies ensuring that all +;;; elements have a valid layout. This re-ordering may destroy CPL ordering so +;;; the inherits should not be read as being in CPL order, and further +;;; duplicates may be introduced. +;;; +(defun order-layout-inherits (layouts) + (declare (simple-vector layouts)) + (let ((length (length layouts)) + (max-depth -1)) + (dotimes (i length) + (let ((depth (layout-inheritance-depth (svref layouts i)))) + (when (> depth max-depth) + (setf max-depth depth)))) + (let* ((new-length (max (1+ max-depth) length)) + (inherits (make-array new-length))) + (dotimes (i length) + (let* ((layout (svref layouts i)) + (depth (layout-inheritance-depth layout))) + (unless (eql depth -1) + (unless (eql (svref inherits depth) 0) + (error "Layout depth confict: ~S~%" layouts)) + (setf (svref inherits depth) layout)))) + (do ((i 0 (1+ i)) + (j 0)) + ((>= i length)) + (declare (type index i j)) + (let* ((layout (svref layouts i)) + (depth (layout-inheritance-depth layout))) + (when (eql depth -1) + (loop (when (eql (svref inherits j) 0) + (return)) + (incf j)) + (setf (svref inherits j) layout)))) + (do ((i (1- new-length) (1- i))) + ((< i 0)) + (declare (type fixnum i)) + (when (eql (svref inherits i) 0) + (setf (svref inherits i) (svref inherits (1+ i))))) + inherits))) + ;;; The CLASS structure is a supertype of all CLASS types. A CLASS is also a ;;; CTYPE structure as recognized by the type system. @@ -758,8 +803,7 @@ generic-sequence collection symbol) :direct-superclasses (list symbol)) - (stream :hierarchical nil :state :read-only - :inherits (instance t))))) + (stream :state :read-only :depth 3 :inherits (instance))))) ;;; See also type-init.lisp where we finish setting up the translations for ;;; built-in types. @@ -767,7 +811,7 @@ (cold-load-init (dolist (x built-in-classes) (destructuring-bind (name &key (translation nil trans-p) inherits codes - enumerable state (hierarchical t) + enumerable state (hierarchical t) depth (direct-superclasses (if inherits (list (car inherits)) '(t)))) x @@ -787,7 +831,9 @@ (setf (class-cell-class (find-class-cell name)) class) (unless trans-p (setf (info type builtin name) class)) - (let* ((inheritance-depth (if hierarchical (length inherits) -1)) + (let* ((inheritance-depth (if hierarchical + (or depth (length inherits)) + -1)) (inherit-layouts (map 'vector #'(lambda (x) @@ -804,20 +850,20 @@ ;;; correctly and the lisp layout replaced by a PCL wrapper after PCL ;;; is loaded and the class defined. (cold-load-init - (dolist (x '((fundamental-stream (t instance stream)))) + (dolist (x '((fundamental-stream (t instance stream stream)))) (let* ((name (first x)) (inherits (second x)) - (class (lisp::make-standard-class :name name)) - (class-cell (lisp::find-class-cell name))) - (setf (lisp::class-cell-class class-cell) class) + (class (make-standard-class :name name)) + (class-cell (find-class-cell name))) + (setf (class-cell-class class-cell) class) (setf (info type class name) class-cell) (setf (info type kind name) :instance) (let ((inherit-layouts (map 'vector #'(lambda (x) - (lisp::class-layout (lisp:find-class x))) + (class-layout (lisp:find-class x))) inherits))) - (lisp::register-layout (lisp::find-layout name 0 inherit-layouts -1) - :invalidate nil))))) + (register-layout (find-layout name 0 inherit-layouts -1) + :invalidate 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. diff --git a/code/error.lisp b/code/error.lisp index a1b98bff2d5851e6f17c5eced30e4800085f606a..9eb7cfd0d7f7a1aa1bd7e51a24f618c1523652c8 100644 --- a/code/error.lisp +++ b/code/error.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.55 2000/07/11 04:19:45 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.56 2000/08/06 19:12:17 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -420,10 +420,10 @@ parent-types))))) (cond-layout (info type compiler-layout 'condition)) (olayout (info type compiler-layout name)) - (new-inherits - (concatenate 'simple-vector - (layout-inherits cond-layout) - (mapcar #'class-layout cpl)))) + (new-inherits + (order-layout-inherits (concatenate 'simple-vector + (layout-inherits cond-layout) + (mapcar #'class-layout cpl))))) (if (and olayout (not (mismatch (layout-inherits olayout) new-inherits))) olayout diff --git a/code/exports.lisp b/code/exports.lisp index 1223c8db97130279476c4951e5994b78c10bbee3..00e1628bac76eb18634cb0fdc163f831009bf221 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.170 2000/07/31 09:53:39 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.171 2000/08/06 19:12:18 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1573,7 +1573,8 @@ "OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-SYMBOL-ERROR" "OBJECT-NOT-TYPE-ERROR" "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR" "OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR" - "ODD-KEYWORD-ARGUMENTS-ERROR" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT" + "ODD-KEYWORD-ARGUMENTS-ERROR" "ORDER-LAYOUT-INHERITS" + "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE" "PARSE-UNKNOWN-TYPE-SPECIFIER" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME" diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index 71fd334e463f4b8b2b20ca6a4145b5b7707129ff..8e3d1d3c481bc0b38670e7f777ddaf0622d213bc 100644 --- a/compiler/typetran.lisp +++ b/compiler/typetran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.37 2000/05/23 06:52:09 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.38 2000/08/06 19:12:27 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -470,7 +470,7 @@ (%layout-invalid-error object ',layout)))) (eq ,n-layout ',layout))))) ((and (typep class 'basic-structure-class) layout) - ;; Structure type tests; hierarchal layout depths. + ;; Structure type tests; hierarchical layout depths. (let ((idepth (layout-inheritance-depth layout)) (n-layout (gensym))) `(and (,pred object) @@ -485,6 +485,22 @@ (eq (svref (layout-inherits ,n-layout) ,idepth) ',layout)))))))) + ((and layout (>= (layout-inheritance-depth layout) 0)) + ;; Hierarchical layout depths. + (let ((idepth (layout-inheritance-depth layout)) + (n-layout (gensym))) + `(and (,pred object) + (let ((,n-layout (,get-layout object))) + ,@(when (policy nil (>= safety speed)) + `((when (layout-invalid ,n-layout) + (%layout-invalid-error object ',layout)))) + (if (eq ,n-layout ',layout) + t + (and (> (length (layout-inherits ,n-layout)) ,idepth) + (locally (declare (optimize (safety 0))) + (eq (svref (layout-inherits ,n-layout) + ,idepth) + ',layout)))))))) (t `(and (,pred object) (class-cell-typep (,get-layout object) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index a6790b8129f46ce9a65e768281469d2b55dbfc37..8082f5a40171f194f6ea31f68b002b8d52f02060 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.17 2000/08/06 19:11:13 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.18 2000/08/06 19:12:33 dtc Exp $") ;;; ;;; Bootstrapping the meta-braid. ;;; @@ -563,8 +563,9 @@ (let ((lclass (kernel:layout-class layout))) (unless (eq (kernel:class-layout lclass) layout) (setf (kernel:layout-inherits layout) - (map 'vector #'class-wrapper - (reverse (rest (class-precedence-list class))))) + (kernel:order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest (class-precedence-list class)))))) (kernel:register-layout layout :invalidate nil) ;; Subclasses of formerly forward-referenced-class may be unknown