From 5f9d61fa93638874b79e9a996a32f2f1a4ae0b4a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 28 Feb 1989 18:23:55 +0000
Subject: [PATCH] Allow stored description of named structure to be either a
 defstruct structure description, or a procedure.  In the latter case the
 procedure is just called to produce the description.

---
 v7/src/runtime/defstr.scm | 56 +++++++++++++++++++++------------------
 1 file changed, 30 insertions(+), 26 deletions(-)

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 9607ebdf4..719010c5e 100644
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 14.5 1989/02/08 22:43:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 14.6 1989/02/28 18:23:55 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -357,18 +357,18 @@ must be defined when the defstruct is evaluated.
 (define (tag->structure tag)
   (if (structure? tag)
       tag
-      (let ((tag (named-structure/get-tag-description tag)))
-	(and tag
-	     (structure? tag)
-	     tag))))
+      (named-structure/get-tag-description tag)))
 
 (define (named-structure? object)
-  (cond ((vector? object)
-	 (and (not (zero? (vector-length object)))
-	      (tag->structure (vector-ref object 0))))
-	((pair? object)
-	 (tag->structure (car object)))
-	(else false)))
+  (let ((object
+	 (cond ((vector? object)
+		(and (not (zero? (vector-length object)))
+		     (tag->structure (vector-ref object 0))))
+	       ((pair? object)
+		(tag->structure (car object)))
+	       (else false))))
+    (or (structure? object)
+	(procedure? object))))
 
 (define (named-structure/description instance)
   (let ((structure
@@ -376,21 +376,25 @@ must be defined when the defstruct is evaluated.
 	  (cond ((vector? instance) (vector-ref instance 0))
 		((pair? instance) (car instance))
 		(else (error "Illegal structure instance" instance))))))
-    (if (not structure)
-	(error "Illegal structure instance" instance))
-    (let ((scheme-type (structure/scheme-type structure)))
-      (if (not (case scheme-type
-		 ((VECTOR) (vector? instance))
-		 ((LIST) (list? instance))
-		 (else (error "Illegal structure type" scheme-type))))
-	  (error "Malformed structure instance" instance))
-      (let ((accessor
-	     (case scheme-type
-	       ((VECTOR) vector-ref)
-	       ((LIST) list-ref))))
-	(map (lambda (slot)
-	       `(,(slot/name slot) ,(accessor instance (slot/index slot))))
-	     (structure/slots structure))))))
+    (cond ((structure? structure)
+	   (let ((scheme-type (structure/scheme-type structure)))
+	     (if (not (case scheme-type
+			((VECTOR) (vector? instance))
+			((LIST) (list? instance))
+			(else (error "Illegal structure type" scheme-type))))
+		 (error "Malformed structure instance" instance))
+	     (let ((accessor
+		    (case scheme-type
+		      ((VECTOR) vector-ref)
+		      ((LIST) list-ref))))
+	       (map (lambda (slot)
+		      `(,(slot/name slot)
+			,(accessor instance (slot/index slot))))
+		    (structure/slots structure)))))
+	  ((procedure? structure)
+	   (structure instance))
+	  (else
+	   (error "Illegal structure instance" instance)))))
 
 ;;;; Code Generation
 
-- 
2.25.1