From 06436096cc6e292a6b610fa9c566935fad9c58e3 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 12 Feb 1990 12:23:28 +0000
Subject: [PATCH] Added new TYPE PRINTER and TYPE DEFINED-STRUCTURE-INFO types.
  Made DEFINE-INFO-TYPE search for an unused type number instead of using
 *TYPE-COUNTER*.  Flushed *TYPE-COUNTER*.

---
 compiler/globaldb.lisp | 31 ++++++++++++++++++++++---------
 1 file changed, 22 insertions(+), 9 deletions(-)

diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index eb004c943..2f791bd4a 100644
--- a/compiler/globaldb.lisp
+++ b/compiler/globaldb.lisp
@@ -87,7 +87,6 @@
 (deftype type-number () `(unsigned-byte ,type-number-bits))
 ;;;
 ;;; Also initialized in GLOBALDB-INIT...
-(defvar *type-counter* 0)
 (defvar *type-numbers*
   (make-array (ash 1 type-number-bits)  :initial-element nil))
 
@@ -180,6 +179,16 @@
     (setf (gethash class *info-classes*) (make-class-info class))))
 
 
+;;; FIND-UNUSED-TYPE-NUMBER  --  Internal
+;;;
+;;;    Find a type number not already in use by looking for a null entry in
+;;; *TYPE-NUMBERS*.
+;;;
+(defun find-unused-type-number ()
+  (or (position nil *type-numbers*)
+      (error "Out of INFO type numbers!")))
+
+
 ;;; Define-Info-Type  --  Public
 ;;;
 ;;;    The main thing we do is determine the type's number.  We need to do this
@@ -203,7 +212,7 @@
 	 (%define-info-type ',class ',type ',type-spec
 			    ,(if old
 				 (type-info-number old)
-				 (incf *type-counter*))))
+				 (find-unused-type-number))))
        (eval-when (load eval)
 	 (setf (type-info-default (type-info-or-lose ',class ',type))
 	       #'(lambda (name) name ,default)))
@@ -213,13 +222,10 @@
 ;;; %Define-Info-Type  --  Internal
 ;;;
 ;;;    If there is no such type, create it.  In any case, set the type
-;;; specifier for the value.  The class must exist.  We bump *TYPE-COUNTER* to
-;;; after our number so that it won't be reused by any new info type
-;;; definition.
+;;; specifier for the value.  The class must exist.
 ;;;
 (defun %define-info-type (class type type-spec number)
   (declare (simple-string class type) (type type-number number))
-  (setq *type-counter* (max *type-counter* (1+ number)))
   (let* ((class-info (class-info-or-lose class))
 	 (old (find-type-info type class-info))
 	 (res (or old
@@ -864,7 +870,6 @@
 	(list (make-info-environment :name "Initial Global")))
   (unless (boundp '*info-classes*)
     (setq *info-classes* (make-hash-table :test #'equal))
-    (setq *type-counter* 0)
     (setq *type-numbers*
 	  (make-array (ash 1 type-number-bits)  :initial-element nil)))
   (function-info-init)
@@ -1012,10 +1017,18 @@
       nil))
 
 ;;; Expander function for a defined type.
-(define-info-type type expander function nil)
+(define-info-type type expander (or function null) nil)
 
-;;; Defstruct description information for a structure type.
+;;; Print function for a type.
+(define-info-type type printer (or function 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)
 
 (define-info-type type documentation (or string null))
 
-- 
GitLab