From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 19 Jun 1997 21:43:01 +0000 (+0000)
Subject: Add option to allow user to specify a different name for the type
X-Git-Tag: 20090517-FFI~5118
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=87781d446f3f2640f17c34cda4af3e8ada0542f8;p=mit-scheme.git

Add option to allow user to specify a different name for the type
descriptor.
---

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index f0ca3663b..2b6e659b9 100644
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: defstr.scm,v 14.30 1996/04/24 04:22:19 cph Exp $
+$Id: defstr.scm,v 14.31 1997/06/19 21:43:01 cph Exp $
 
-Copyright (c) 1988-96 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -237,6 +237,11 @@ differences:
 		  (if (not (memq (car arguments) '(VECTOR LIST)))
 		      (error "Illegal structure option:" option))
 		  (set! type (car arguments)))
+		 ((TYPE-DESCRIPTOR)
+		  (check-duplicate)
+		  (check-argument)
+		  (set! type-name (car arguments))
+		  (set! tag-expression type-name))
 		 ((NAMED)
 		  (check-duplicate)
 		  (check-arguments 1)
@@ -268,8 +273,11 @@ differences:
 			(cdr constructors)))
 	    (loop (cdr constructors)))))
     (let ((type-seen? (assq 'TYPE options-seen))
+	  (type-descriptor-seen? (assq 'TYPE-DESCRIPTOR options-seen))
 	  (named-seen? (assq 'NAMED options-seen)))
-      (let ((named? (or (not type-seen?) named-seen?)))
+      (if (and type-descriptor-seen? named-seen?)
+	  (error "Conflicting options:" type-descriptor-seen? named-seen?))
+      (let ((named? (or (not type-seen?) type-descriptor-seen? named-seen?)))
 	(if (not type-seen?)
 	    (let ((check-option
 		   (lambda (seen?)