From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 22 Feb 2018 07:35:23 +0000 (-0800)
Subject: Make sure that tagged vector/pair predicates are registered.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~228
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b3de5513be0b4fc63506c42821d9466d9d84b989;p=mit-scheme.git

Make sure that tagged vector/pair predicates are registered.
---

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index fdb65328e..960c3c91f 100644
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -758,27 +758,34 @@ differences:
     (if predicate-name
 	(let* ((context (structure/context structure))
 	       (tag-expression
-		(close (structure/tag-expression structure) context)))
+		(close (structure/tag-expression structure) context))
+	       (name (parser-context/name context)))
 	  (case (structure/physical-type structure)
-	    ((RECORD)
-	     `((DEFINE ,predicate-name
-		 (,(absolute 'RECORD-PREDICATE context)
+	    ((record)
+	     `((define ,predicate-name
+		 (,(absolute 'record-predicate context)
 		  ,(close (structure/type-descriptor structure) context)))))
-	    ((VECTOR)
-	     `((DEFINE (,predicate-name OBJECT)
-		 (AND (,(absolute 'VECTOR? context) OBJECT)
-		      (,(absolute 'NOT context)
-		       (,(absolute 'ZERO? context)
-			(,(absolute 'VECTOR-LENGTH context) OBJECT)))
-		      (,(absolute 'EQ? context)
-		       (,(absolute 'VECTOR-REF context) OBJECT 0)
-		       ,tag-expression)))))
-	    ((LIST)
-	     `((DEFINE (,predicate-name OBJECT)
-		 (AND (,(absolute 'PAIR? context) OBJECT)
-		      (,(absolute 'EQ? context)
-		       (,(absolute 'CAR context) OBJECT)
-		       ,tag-expression)))))))
+	    ((vector)
+	     `((define (,predicate-name object)
+		 (and (,(absolute 'vector? context) object)
+		      (,(absolute 'not context)
+		       (,(absolute 'zero? context)
+			(,(absolute 'vector-length context) object)))
+		      (,(absolute 'eq? context)
+		       (,(absolute 'vector-ref context) object 0)
+		       ,tag-expression)))
+	       (,(absolute 'register-predicate! context)
+		,predicate-name ',name
+		'<= ,(absolute 'vector? context))))
+	    ((list)
+	     `((define (,predicate-name object)
+		 (and (,(absolute 'pair? context) object)
+		      (,(absolute 'eq? context)
+		       (,(absolute 'car context) object)
+		       ,tag-expression)))
+	       (,(absolute 'register-predicate! context)
+		,predicate-name ',name
+		'<= ,(absolute 'pair? context))))))
 	'())))
 
 (define (type-definitions structure)