From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 17 Nov 1992 21:37:49 +0000 (+0000)
Subject: Add description to output of DEFINE-NAMED-STRUCTURE so that PP knows
X-Git-Tag: 20090517-FFI~8758
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=908e90c145ac036c76bc748107ae5d0f94343834;p=mit-scheme.git

Add description to output of DEFINE-NAMED-STRUCTURE so that PP knows
how to print out these structures in a useful way.
---

diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm
index d7c686ded..29f4ed64a 100644
--- a/v7/src/edwin/macros.scm
+++ b/v7/src/edwin/macros.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: macros.scm,v 1.57 1992/11/16 22:41:07 cph Exp $
+;;;	$Id: macros.scm,v 1.58 1992/11/17 21:37:49 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-1992 Massachusetts Institute of Technology
 ;;;
@@ -76,7 +76,7 @@
 	  (if (null? slot-names)
 	      '()
 	      (cons `(DEFINE-INTEGRABLE ,(car slot-names) ,n)
-		    (slot-loop (cdr slot-names) (1+ n)))))
+		    (slot-loop (cdr slot-names) (+ n 1)))))
 
 	(define (selector-loop selector-names n)
 	  (if (null? selector-names)
@@ -84,12 +84,12 @@
 	      (cons `(DEFINE-INTEGRABLE
 		       (,(car selector-names) ,structure-name)
 		       (VECTOR-REF ,structure-name ,n))
-		    (selector-loop (cdr selector-names) (1+ n)))))
+		    (selector-loop (cdr selector-names) (+ n 1)))))
 
 	`(BEGIN (DEFINE ,tag-name ,name)
 		(DEFINE (,constructor-name)
 		  (LET ((,structure-name
-			 (MAKE-VECTOR ,(1+ (length slots)) '())))
+			 (MAKE-VECTOR ,(+ (length slots) 1) '())))
 		    (VECTOR-SET! ,structure-name 0 ,tag-name)
 		    ,structure-name))
 		(DEFINE (,predicate-name OBJECT)
@@ -99,6 +99,13 @@
 		(UNPARSER/SET-TAGGED-VECTOR-METHOD!
 		 ,tag-name
 		 (UNPARSER/STANDARD-METHOD ',structure-name))
+		(NAMED-STRUCTURE/SET-TAG-DESCRIPTION!
+		 ,tag-name
+		 (LAMBDA (OBJECT)
+		   (LIST ,@(map (lambda (slot selector-name)
+				  `(LIST ',slot (,selector-name OBJECT)))
+				slots
+				selector-names))))
 		,@(slot-loop slot-names 1)
 		,@(selector-loop selector-names 1))))))