From e8294d58085b6e60607a3a9a0eae6161979e25d4 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 23 Jan 1993 14:48:04 +0000
Subject: [PATCH] New structure hax.

---
 code/type-boot.lisp           | 45 +----------------------
 compiler/dump.lisp            | 27 +++++++++++---
 compiler/generic/interr.lisp  |  5 +--
 compiler/generic/vm-tran.lisp |  3 +-
 compiler/globaldb.lisp        | 67 +++++++++++++++++++++--------------
 compiler/ir1tran.lisp         | 10 +++---
 compiler/mips/call.lisp       |  3 +-
 compiler/proclaim.lisp        | 26 ++------------
 compiler/typetran.lisp        |  4 +--
 9 files changed, 81 insertions(+), 109 deletions(-)

diff --git a/code/type-boot.lisp b/code/type-boot.lisp
index 4c632dd71..3cb91b329 100644
--- a/code/type-boot.lisp
+++ b/code/type-boot.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/type-boot.lisp,v 1.6 1991/02/08 13:36:35 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type-boot.lisp,v 1.6.1.1 1993/01/23 14:30:29 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -16,51 +16,8 @@
 ;;;
 (in-package "C")
 
-;;; Make these types be sort-of-defined to allow bootstrapping.
-(setf (info type defined-structure-info 'defstruct-description)
-      (make-defstruct-description))
-
-(setf (info type defined-structure-info 'defstruct-slot-description)
-      (make-defstruct-description))
-
-
-;;; Define this now so that EQUAL works:
-;;;
-(defun pathnamep (x)
-  (and (structurep x) (eq (structure-ref x 0) 'pathname)))
-
-;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of
-;;; initialization.
-;;;
-(defun volatile-info-env-p (x)
-  (and (structurep x) (eq (structure-ref x 0) 'volatile-info-env)))
-
-
 (deftype inlinep ()
   '(member :inline :maybe-inline :notinline nil))
 
 (deftype boolean ()
   '(member t nil))
-
-;;; Define this so that we can define the type system.
-(in-package "KERNEL")
-(defun ctype-p (thing)
-  (and (structurep thing)
-       (member (c::structure-ref thing 0)
-	       '(ctype hairy-type named-type numeric-type array-type
-		       member-type structure-type union-type args-type
-		       values-type function-type))))
-
-(defun values-type-p (thing)
-  (and (structurep thing) (eq (c::structure-ref thing 0) 'values-type)))
-
-;;; Define this so that we can copy type-class structures before the defstruct
-;;; for type-class runs.
-;;;
-(defun copy-type-class (tc)
-  (let ((new (make-type-class)))
-    (dotimes (i (c::structure-length tc))
-      (declare (type index i))
-      (setf (c::structure-ref new i)
-	    (c::structure-ref tc i)))
-    new))
diff --git a/compiler/dump.lisp b/compiler/dump.lisp
index eb135a1a4..c4450924d 100644
--- a/compiler/dump.lisp
+++ b/compiler/dump.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.47.1.1 1993/01/15 15:30:50 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.47.1.2 1993/01/23 14:38:03 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -835,7 +835,10 @@
 	      (unless (equal-check-table x file)
 		(dump-list x file)
 		(equal-save-object x file)))
-	     (structure
+	     (layout
+	      (dump-layout x file)
+	      (eq-save-object x file))
+	     (instance
 	      (dump-structure x file)
 	      (eq-save-object x file))
 	     (array
@@ -923,7 +926,7 @@
 ;;; overhead on types of objects that might be circular.
 ;;;
 (defun dump-object (x file)
-  (if (or (array-header-p x) (simple-vector-p x) (consp x) (structurep x))
+  (if (or (array-header-p x) (simple-vector-p x) (consp x) (instancep x))
       (let ((*circularities-detected* ())
 	    (circ (fasl-file-circularity-table file)))
 	(clrhash circ)
@@ -1421,11 +1424,11 @@
 	     struct)))
   (note-potential-circularity struct file)
   (do ((index 0 (1+ index))
-       (length (structure-length struct))
+       (length (%instance-length struct))
        (circ (fasl-file-circularity-table file)))
       ((= index length)
        (dump-fop* length lisp::fop-small-struct lisp::fop-struct file))
-    (let* ((obj (structure-ref struct index))
+    (let* ((obj (%instance-ref struct index))
 	   (ref (gethash obj circ)))
       (cond (ref
 	     (push (make-circularity :type :struct-set
@@ -1438,3 +1441,17 @@
 	    (t
 	     (sub-dump-object obj file))))))
 
+(defun dump-layout (obj file)
+  (unless (member (layout-invalid obj) '(nil :compiler))
+    (compiler-error "Dumping reference to obsolete class: ~S"
+		    (layout-class obj)))
+  (let ((name (class-name (layout-class obj))))
+    (assert name)
+    (dump-fop 'lisp::fop-normal-load file)
+    (let ((*cold-load-dump* t))
+      (dump-object name file))
+    (dump-fop 'lisp::fop-maybe-cold-load file))
+  (sub-dump-object (layout-inherits obj) file)
+  (sub-dump-object (layout-inheritance-depth obj) file)
+  (sub-dump-object (layout-length obj) file)
+  (dump-fop 'lisp::fop-layout file))
diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp
index 03407dada..b60b17185 100644
--- a/compiler/generic/interr.lisp
+++ b/compiler/generic/interr.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.2 1992/03/22 17:30:26 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.2.1.1 1993/01/23 14:44:53 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -152,4 +152,5 @@
   (object-not-base-char
    "Object is not of type BASE-CHAR.")
   (nil-function-returned
-   "Function with declared result type NIL returned."))
+   "Function with declared result type NIL returned.")
+  (layout-invalid
diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index c8e289c7e..354dbe7d3 100644
--- a/compiler/generic/vm-tran.lisp
+++ b/compiler/generic/vm-tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.27.1.1 1993/01/14 21:02:52 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.27.1.2 1993/01/23 14:45:45 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -47,6 +47,7 @@
 		`(truly-the nil
 			    (%primitive ,',primitive ,@foo)))))
   (frob %type-check-error type-check-error)
+  (frob %layout-invalid-error layout-invalid-error)
   (frob %odd-keyword-arguments-error odd-keyword-arguments-error)
   (frob %unknown-keyword-argument-error unknown-keyword-argument-error)
   (frob %argument-count-error argument-count-error))
diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index afa8ff092..cba638fed 100644
--- a/compiler/globaldb.lisp
+++ b/compiler/globaldb.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.26 1992/12/17 11:31:24 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.26.1.1 1993/01/23 14:41:11 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -36,7 +36,7 @@
 (in-package "EXTENSIONS")
 (export '(info clear-info define-info-class define-info-type
 	       make-info-environment do-info *info-environment*
-	       compact-info-environment))
+	       compact-info-environment undefine-function-name))
 
 (in-package "C")
 
@@ -1091,36 +1091,17 @@
 
 (define-info-class type)
 
-;;; The kind of type described.  We return :Structure for standard types that
+;;; The kind of type described.  We return :Instance for standard types that
 ;;; are implemented as structures.
 ;;;
-(define-info-type type kind (member :primitive :defined :structure nil)
-  (if (or (info type builtin name)
-	  (info type translator name))
-      :primitive
-      nil))
+(define-info-type type kind (member :primitive :defined :instance nil) nil)
 
 ;;; Expander function for a defined type.
 (define-info-type type expander (or function null) nil)
 
-;;; Print function for a type.
-(define-info-type type printer (or function symbol null) nil)
-
-;;; Make-load-form function for a type.
-(define-info-type type load-form-maker (or function symbol null) nil)
-
-;;; Defstruct description information for a structure type.  DEFINED is the
-;;; current global definition, and is not shadowed by compilation of
-;;; structure definitions.
-;;;
-(define-info-type type structure-info (or defstruct-description null) nil)
-(define-info-type type defined-structure-info (or defstruct-description null)
-  nil)
-
-;;; True if this type has been frozen with the FREEZE-TYPE declaration.  Only
-;;; interesting for structure types.
+;;; Layout for this type being used by the compiler.
 ;;;
-(define-info-type type frozen boolean nil)
+(define-info-type type compiler-layout (or layout null) nil)
 
 (define-info-type type documentation (or string null))
 
@@ -1128,10 +1109,21 @@
 ;;;
 (define-info-type type translator (or function null) nil)
 
-;;; If true, then the type coresponding to this name.
+;;; If true, then the type coresponding to this name.  Note that if this is a
+;;; built-in class with a translation, then this is the translation, not the
+;;; class object.  This info type keeps track of random atomic types (NIL etc.)
+;;; and also serves as a cache to ensure that common standard types (atomic and
+;;; otherwise) are only consed once.
 ;;;
 (define-info-type type builtin (or ctype null) nil)
 
+;;; If this type is a class name, then this is the corresponding class.  Note
+;;; that for built-in classes, the kind may be :PRIMITIVE and not :INSTANCE.
+;;;
+(define-info-type type class (or class null) nil)
+
+(define-info-class typed-structure)
+(define-info-type typed-structure info)
 
 (define-info-class declaration)
 (define-info-type declaration recognized boolean)
@@ -1160,3 +1152,26 @@
 (define-info-type random-documentation stuff list ())
 
 ); defun other-info-init
+
+;;;; Random utilities:
+
+;;; UNDEFINE-FUNCTION-NAME  --  Interface
+;;;
+;;;    Make Name no longer be a function name: clear everything back to the
+;;; default.
+;;;
+(defun undefine-function-name (name)
+  (when name
+    (macrolet ((frob (type &optional val)
+		 `(unless (eq (info function ,type name) ,val)
+		    (setf (info function ,type name) ,val))))
+      (frob info)
+      (frob type (specifier-type 'function))
+      (frob where-from :assumed)
+      (frob inlinep)
+      (frob kind)
+      (frob accessor-for)
+      (frob inline-expansion)
+      (frob source-transform)
+      (frob assumed-type)))
+  (undefined-value))
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index a75a7754f..56f2b06f9 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.83.1.1 1993/01/15 15:31:34 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.83.1.2 1993/01/23 14:42:04 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2596,13 +2596,13 @@
 ;;; %Compiler-Defstruct IR1 Convert  --  Internal
 ;;;
 ;;;    This is a frob that DEFMACRO expands into to establish the compiler
-;;; semantics.  %COMPILER-ONLY-DEFSTRUCT and %%COMPILER-DEFSTRUCT do most of
-;;; the work, we just clear all of the functions out of *FREE-FUNCTIONS* to
-;;; keep things in synch.  %%COMPILER-DEFSTRUCT is also called at load-time.
+;;; semantics.  The other code in the expansion and %%COMPILER-DEFSTRUCT do
+;;; most of the work, we just clear all of the functions out of
+;;; *FREE-FUNCTIONS* to keep things in synch.  %%COMPILER-DEFSTRUCT is also
+;;; called at load-time.
 ;;;
 (def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
   (let* ((info (eval info)))
-    (%compiler-only-defstruct info)
     (%%compiler-defstruct info)
     (dolist (slot (dd-slots info))
       (let ((fun (dsd-accessor slot)))
diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp
index e0c1e6437..aa75867fb 100644
--- a/compiler/mips/call.lisp
+++ b/compiler/mips/call.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.52.1.1 1993/01/15 14:16:10 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.52.1.2 1993/01/23 14:48:04 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1264,6 +1264,7 @@ default-value-8
 		  (error-call vop ,error ,@args)))))
   (frob argument-count-error invalid-argument-count-error nargs)
   (frob type-check-error object-not-type-error object type)
+  (frob layout-invalid-error layout-invalid-error object layout)
   (frob odd-keyword-arguments-error odd-keyword-arguments-error)
   (frob unknown-keyword-argument-error unknown-keyword-argument-error key)
   (frob nil-function-returned-error nil-function-returned-error fun))
diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index e291e0fbf..ebc0d99b6 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.26.1.1 1993/01/15 15:31:55 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.26.1.2 1993/01/23 14:39:22 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,6 +21,8 @@
 
 (in-package "EXTENSIONS")
 (export '(inhibit-warnings freeze-type optimize-interface constant-function))
+(in-package "KERNEL")
+(export '(note-name-defined *type-system-initialized*))
 (in-package "LISP")
 (export '(declaim proclaim))
 (in-package "C")
@@ -236,28 +238,6 @@
   name)
 
 
-;;; UNDEFINE-FUNCTION-NAME  --  Interface
-;;;
-;;;    Make Name no longer be a function name: clear everything back to the
-;;; default.
-;;;
-(defun undefine-function-name (name)
-  (when name
-    (macrolet ((frob (type &optional val)
-		 `(unless (eq (info function ,type name) ,val)
-		    (setf (info function ,type name) ,val))))
-      (frob info)
-      (frob type (specifier-type 'function))
-      (frob where-from :assumed)
-      (frob inlinep)
-      (frob kind)
-      (frob accessor-for)
-      (frob inline-expansion)
-      (frob source-transform)
-      (frob assumed-type)))
-  (undefined-value))
-
-
 ;;; Process-Optimize-Declaration  --  Interface
 ;;;
 ;;;    Return a new cookie containing the policy information represented by the
diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
index 5d11343d9..2e8cd9d6a 100644
--- a/compiler/typetran.lisp
+++ b/compiler/typetran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.14.1.1 1993/01/15 15:32:22 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.14.1.2 1993/01/23 14:34:43 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -137,7 +137,7 @@
   (define-type-predicate simple-string-p simple-string)
   (define-type-predicate simple-vector-p simple-vector)
   (define-type-predicate stringp string)
-  (define-type-predicate structurep structure)
+  (define-type-predicate instancep instance)
   (define-type-predicate symbolp symbol)
   (define-type-predicate vectorp vector))
 
-- 
GitLab