From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 11 Jan 2018 03:19:58 +0000 (-0800)
Subject: Tweak dispatch-tag slightly.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~382
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=da47ca24210b68381ab1f27ed6bc7a55c6d69bd1;p=mit-scheme.git

Tweak dispatch-tag slightly.
---

diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm
index 41a83e065..e60f9e098 100644
--- a/src/runtime/gentag.scm
+++ b/src/runtime/gentag.scm
@@ -90,22 +90,22 @@ USA.
 
 ;;;; Object Tags
 
-;;; We assume that most new data types will be constructed from tagged
-;;; vectors, and therefore we should optimize the path for such
-;;; structures as much as possible.
+;;; We assume that most new data types will be constructed from records, and
+;;; therefore we should optimize the path for such structures as much as
+;;; possible.
 
 (define (dispatch-tag object)
   (declare (integrate object))
   (declare (ignore-reference-traps (set microcode-type-tag-table
 					microcode-type-method-table)))
-  (if (and (%record? object)
-	   (%record? (%record-ref object 0))
-	   (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
-      (%record-ref object 0)
-      (if (vector-ref microcode-type-tag-table (object-type object))
-	  (vector-ref microcode-type-tag-table (object-type object))
-	  ((vector-ref microcode-type-method-table (object-type object))
-	   object))))
+  (cond ((and (%record? object)
+	      (dispatch-tag? (%record-ref object 0)))
+	 (%record-ref object 0))
+	((vector-ref microcode-type-tag-table (object-type object))
+	 (vector-ref microcode-type-tag-table (object-type object)))
+	(else
+	 ((vector-ref microcode-type-method-table (object-type object))
+	  object))))
 
 (define (make-built-in-tag names)
   (let ((tags (map built-in-dispatch-tag names)))