From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 10 Dec 1987 21:52:18 +0000 (+0000)
Subject: The type object being constructed for named structures of type LIST
X-Git-Tag: 20090517-FFI~12994
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bed001ed6aeff20596ca423dd1bdd03eef4defe5;p=mit-scheme.git

The type object being constructed for named structures of type LIST
was incorrect.
---

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index 698bdb89a..94a41f709 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 1.5 1987/12/08 14:01:05 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 1.6 1987/12/10 21:52:18 cph Exp $
 ;;;
 ;;;	Copyright (c) 1987 Massachusetts Institute of Technology
 ;;;
@@ -533,24 +533,23 @@ functionality is not implemented.
      (write (hash structure-instance)))))
 
 (define (make-structure-type structure tag)
-  (let ((type
-	 (make-sub-type
-	  (structure/name structure)
-	  (microcode-type-object 'vector)
-	  (case (structure/scheme-type structure)
-	    ((VECTOR)
-	     (lambda (vector)
-	       (and (not (zero? (vector-length vector)))
-		    (eq? (vector-ref vector 0) tag))))
-	    ((LIST)
-	     (lambda (pair)
-	       (eq? (car pair) tag)))
-	    (else
-	     (error "Unknown scheme type" structure))))))
-    (if (not tag)
-	(set! tag type))
-    (2d-put! tag tag->structure structure)
-    type))
+  (let ((scheme-type (structure/scheme-type structure)))
+    (let ((type
+	   (make-sub-type
+	    (structure/name structure)
+	    (microcode-type-object scheme-type)
+	    (case scheme-type
+	      ((VECTOR)
+	       (lambda (vector)
+		 (and (not (zero? (vector-length vector)))
+		      (eq? (vector-ref vector 0) tag))))
+	      ((LIST)
+	       (lambda (pair)
+		 (eq? (car pair) tag)))
+	      (else
+	       (error "Unknown scheme type" structure))))))
+      (2d-put! (or tag type) tag->structure structure)
+      type)))
 
 (define (structure-instance->description structure)
   (2d-get (cond ((and (vector? structure)