From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 18 Jan 2018 04:20:52 +0000 (-0800)
Subject: Eliminate remaining differences between record tags and types.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~346
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c95549be8f4d8ef350ece8b2c0d75d346bad570a;p=mit-scheme.git

Eliminate remaining differences between record tags and types.

Also simplify internals of record a bit as a consequence.
---

diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index 4125e45d8..64bea8082 100644
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -714,9 +714,7 @@ differences:
 	(tag-expression (close (structure/tag-expression structure) context)))
     (if (structure/record-type? structure)
 	`(DEFINE ,name
-	   (LET ((TAG
-		  (,(absolute 'RECORD-TYPE-DISPATCH-TAG context)
-		   ,tag-expression)))
+	   (LET ((TAG ,tag-expression))
 	     ,(capture-syntactic-environment
 	       (lambda (environment)
 		 `(NAMED-LAMBDA (,name ,@lambda-list)
diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 39fc9901e..29364bc43 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -514,13 +514,12 @@ USA.
 (define (normalize-aliens! args)
   ;; Any vectors among ARGS are assumed to be freshly-consed aliens
   ;; without their record-type.  Fix them.
-  (let ((tag (record-type-dispatch-tag rtd:alien)))
-    (let loop ((args args))
-      (if (null? args)
-	  unspecific
-	  (let ((arg (car args)))
-	    (if (%record? arg) (%record-set! arg 0 tag))
-	    (loop (cdr args)))))))
+  (let loop ((args args))
+    (if (null? args)
+	unspecific
+	(let ((arg (car args)))
+	  (if (%record? arg) (%record-set! arg 0 rtd:alien))
+	  (loop (cdr args))))))
 
 (define (callback-handler id args)
   ;; Installed in the fixed-objects-vector, this procedure is called
diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 5b68da592..0f3a07c68 100644
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -71,9 +71,8 @@ USA.
 (define (finalize-package-record-type!)
   (let ((rtd
 	 (make-record-type "package" '(PARENT CHILDREN NAME ENVIRONMENT))))
-    (let ((tag (record-type-dispatch-tag rtd)))
-      (set! package-tag tag)
-      (for-each (lambda (p) (%record-set! p 0 tag)) *packages*))
+    (set! package-tag rtd)
+    (for-each (lambda (p) (%record-set! p 0 rtd)) *packages*)
     (define-unparser-method (record-predicate rtd)
       (simple-unparser-method 'package
 	(lambda (package)
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index aa21b55a1..c9c3e29d3 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -35,16 +35,13 @@ USA.
 (define-primitives
   (vector-cons 2))
 
-(define-integrable (%record-tag record)
-  (%record-ref record 0))
-
 (define-integrable (%tagged-record? tag object)
   (and (%record? object)
-       (eq? (%record-tag object) tag)))
+       (eq? tag (%record-ref object 0))))
 
 (define (%copy-record record)
   (let ((length (%record-length record)))
-    (let ((result (%make-record (%record-tag record) length)))
+    (let ((result (%make-record (%record-ref record 0) length)))
       (do ((index 1 (fix:+ index 1)))
 	  ((fix:= index length))
 	(%record-set! result index (%record-ref record index)))
@@ -71,12 +68,12 @@ USA.
 	    (lambda (object)
 	      (%tagged-record? tag object)))
 	   (tag
-	    (%make-record-tag (string->symbol (->type-name type-name))
-			      predicate
-			      names
-			      (if (default-object? default-inits)
-				  (vector-cons n #f)
-				  (list->vector default-inits)))))
+	    (%make-record-type (->type-name type-name)
+			       predicate
+			       names
+			       (if (default-object? default-inits)
+				   (vector-cons n #f)
+				   (list->vector default-inits)))))
 	(if (and unparser-method
 		 (not (default-object? unparser-method)))
 	    (define-unparser-method predicate unparser-method))
@@ -95,60 +92,35 @@ USA.
 		      default-inits))))
   unspecific)
 
-(define record-tag-metatag)
-(define record-tag?)
-(define %make-record-tag)
-(define record-type-type-tag)
+(define record-type?)
+(define %make-record-type)
 (add-boot-init!
  (lambda ()
-   (set! record-tag-metatag (make-dispatch-metatag 'record-tag))
-   (set! record-tag? (dispatch-tag->predicate record-tag-metatag))
-   (set! %make-record-tag
-	 (dispatch-metatag-constructor record-tag-metatag 'make-record-type))
-   unspecific))
-
-(define (record-tag->type-descriptor tag)
-  (guarantee record-tag? tag 'record-tag->type-descriptor)
-  tag)
-
-(define (record-type? object)
-  (record-tag? object))
+   (let ((metatag (make-dispatch-metatag 'record-tag)))
+     (set! record-type? (dispatch-tag->predicate metatag))
+     (set! %make-record-type
+	   (dispatch-metatag-constructor metatag 'make-record-type))
+     unspecific)))
 
-(define-integrable (%record-type-descriptor record)
-  (%record-tag record))
-
-(define-integrable (%record-type-dispatch-tag record-type)
+;; Can be deleted after 9.3 release:
+(define (record-type-dispatch-tag record-type)
   record-type)
 
-(define-integrable (%record-type-name record-type)
-  (symbol->string (dispatch-tag-name record-type)))
-
 (define-integrable (%record-type-field-names record-type)
   (dispatch-tag-extra record-type 0))
 
 (define-integrable (%record-type-default-inits record-type)
   (dispatch-tag-extra record-type 1))
 
-(define-integrable (%record-type-predicate record-type)
-  (dispatch-tag->predicate (%record-type-dispatch-tag record-type)))
-
 (define-integrable (%record-type-n-fields record-type)
   (vector-length (%record-type-field-names record-type)))
 
 (define-integrable (%record-type-length record-type)
   (fix:+ 1 (%record-type-n-fields record-type)))
 
-(define-integrable (%record-type-field-name record-type index)
-  (vector-ref (%record-type-field-names record-type)
-	      (fix:- index 1)))
-
-(define (record-type-dispatch-tag record-type)
-  (guarantee record-type? record-type 'record-type-dispatch-tag)
-  (%record-type-dispatch-tag record-type))
-
 (define (record-type-name record-type)
   (guarantee record-type? record-type 'record-type-name)
-  (%record-type-name record-type))
+  (symbol->string (dispatch-tag-name record-type)))
 
 (define (record-type-field-names record-type)
   (guarantee record-type? record-type 'record-type-field-names)
@@ -193,14 +165,13 @@ USA.
 			       (append names (list (make-name i)))))
 		   default)))))))
     (lambda (record-type)
-      (let ((tag (%record-type-dispatch-tag record-type))
-	    (n-fields (%record-type-n-fields record-type)))
-	(expand-cases tag n-fields 16
+      (let ((n-fields (%record-type-n-fields record-type)))
+	(expand-cases record-type n-fields 16
 	  (let ((reclen (fix:+ 1 n-fields)))
 	    (letrec
 		((constructor
 		  (lambda field-values
-		    (let ((record (%make-record tag reclen))
+		    (let ((record (%make-record record-type reclen))
 			  (lose
 			   (lambda ()
 			     (error:wrong-number-of-arguments constructor
@@ -248,7 +219,7 @@ USA.
 						      (length indexes)
 						      field-values))))
 	      (let ((record
-		     (%make-record (%record-type-dispatch-tag record-type)
+		     (%make-record record-type
 				   (%record-type-length record-type))))
 		(do ((indexes indexes (cdr indexes))
 		     (values field-values (cdr values)))
@@ -271,8 +242,7 @@ USA.
       ((constructor
 	(lambda keyword-list
 	  (let ((n (%record-type-length record-type)))
-	    (let ((record
-                   (%make-record (%record-type-dispatch-tag record-type) n))
+	    (let ((record (%make-record record-type n))
 		  (seen? (vector-cons n #f)))
 	      (do ((kl keyword-list (cddr kl)))
 		  ((not (and (pair? kl)
@@ -296,11 +266,11 @@ USA.
 
 (define (record? object)
   (and (%record? object)
-       (record-tag? (%record-tag object))))
+       (record-type? (%record-ref object 0))))
 
 (define (record-type-descriptor record)
   (guarantee record? record 'record-type-descriptor)
-  (%record-type-descriptor record))
+  (%record-ref record 0))
 
 (define (copy-record record)
   (guarantee record? record 'copy-record)
@@ -308,12 +278,11 @@ USA.
 
 (define (record-predicate record-type)
   (guarantee record-type? record-type 'record-predicate)
-  (%record-type-predicate record-type))
+  (dispatch-tag->predicate record-type))
 
 (define (record-accessor record-type field-name)
   (guarantee record-type? record-type 'record-accessor)
-  (let ((tag (%record-type-dispatch-tag record-type))
-	(predicate (%record-type-predicate record-type))
+  (let ((predicate (record-predicate record-type))
 	(index (record-type-field-index record-type field-name #t)))
     (let-syntax
 	((expand-cases
@@ -324,7 +293,7 @@ USA.
 		   (gen-accessor
 		    (lambda (i)
 		      `(lambda (record)
-			 (if (not (%tagged-record? tag record))
+			 (if (not (%tagged-record? record-type record))
 			     (error:not-a predicate record))
 			 (%record-ref record ,i)))))
 	       (let loop ((i 1))
@@ -337,8 +306,7 @@ USA.
 
 (define (record-modifier record-type field-name)
   (guarantee record-type? record-type 'record-modifier)
-  (let ((tag (%record-type-dispatch-tag record-type))
-	(predicate (%record-type-predicate record-type))
+  (let ((predicate (record-predicate record-type))
 	(index (record-type-field-index record-type field-name #t)))
     (let-syntax
 	((expand-cases
@@ -349,7 +317,7 @@ USA.
 		   (gen-accessor
 		    (lambda (i)
 		      `(lambda (record field-value)
-			 (if (not (%tagged-record? tag record))
+			 (if (not (%tagged-record? record-type record))
 			     (error:not-a predicate record))
 			 (%record-set! record ,i field-value)))))
 	       (let loop ((i 1))
@@ -377,8 +345,8 @@ USA.
 					error?))))))
 
 (define (->type-name object)
-  (cond ((string? object) (string->immutable object))
-	((symbol? object) (symbol->string object))
+  (cond ((string? object) (string->symbol object))
+	((symbol? object) object)
 	(else (error:wrong-type-argument object "type name" #f))))
 
 (define (list-of-unique-symbols? object)
@@ -401,13 +369,15 @@ USA.
   (standard-unparser-method
    (lambda (record)
      (strip-angle-brackets
-      (%record-type-name (%record-type-descriptor record))))
+      (dispatch-tag-name (record-type-descriptor record))))
    #f))
 
-(define-unparser-method record-type?
-  (simple-unparser-method 'record-type
-    (lambda (type)
-      (list (%record-type-name type)))))
+(add-boot-init!
+ (lambda ()
+   (define-unparser-method record-type?
+     (simple-unparser-method 'record-type
+       (lambda (type)
+	 (list (dispatch-tag-name type)))))))
 
 (define-pp-describer %record?
   (lambda (record)
@@ -419,7 +389,7 @@ USA.
 
 (define-pp-describer record?
   (lambda (record)
-    (let ((type (%record-type-descriptor record)))
+    (let ((type (record-type-descriptor record)))
       (map (lambda (field-name)
 	     `(,field-name
 	       ,((record-accessor type field-name) record)))
@@ -727,14 +697,20 @@ USA.
   (or (and (fix:> index 0)
 	   (record? record)
 	   (let ((names
-		  (%record-type-field-names (%record-type-descriptor record))))
+		  (%record-type-field-names (record-type-descriptor record))))
 	     (and (fix:<= index (vector-length names))
 		  (vector-ref names (fix:- index 1)))))
       index))
 
 (define (record-type-field-name record-type index)
   (guarantee record-type? record-type 'record-type-field-name)
-  (%record-type-field-name record-type index))
+  (guarantee fix:fixnum? index 'record-type-field-name)
+  (let ((names (%record-type-field-names record-type))
+	(index* (fix:- index 1)))
+    (if (not (fix:>= index* 0)
+	     (fix:< index* (vector-length names)))
+	(error:bad-range-argument index 'record-type-field-name))
+    (vector-ref names index*)))
 
 (define (store-value-restart location k thunk)
   (let ((location (write-to-string location)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1be5fcac8..36928f0de 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3731,7 +3731,7 @@ USA.
 	  record-predicate
 	  record-type-default-value-by-index
 	  record-type-descriptor
-	  record-type-dispatch-tag
+	  record-type-dispatch-tag	;can be deleted after 9.3 release
 	  record-type-field-names
 	  record-type-name
 	  record-type?
@@ -3740,8 +3740,6 @@ USA.
   (export (runtime)
 	  error:no-such-slot
 	  error:uninitialized-slot
-	  record-tag->type-descriptor
-	  record-tag?
 	  record-type-field-index)
   (initialization (initialize-package!)))
 
diff --git a/src/sos/class.scm b/src/sos/class.scm
index d734af1cd..d04dc2a2c 100644
--- a/src/sos/class.scm
+++ b/src/sos/class.scm
@@ -341,7 +341,7 @@ USA.
   (dispatch-tag->class (object->dispatch-tag object)))
 
 (define (record-type-class type)
-  (dispatch-tag->class (record-type-dispatch-tag type)))
+  (dispatch-tag->class type))
 
 (define (record-class record)
   (record-type-class (record-type-descriptor record)))
@@ -349,9 +349,8 @@ USA.
 (define (dispatch-tag->class tag)
   (cond ((class-tag? tag) (dispatch-tag-extra tag 0))
 	((hash-table/get built-in-class-table tag #f))
-	((record-tag? tag)
-	 (let ((class
-		(make-record-type-class (record-tag->type-descriptor tag))))
+	((record-type? tag)
+	 (let ((class (make-record-type-class tag)))
 	   (hash-table/put! built-in-class-table tag class)
 	   class))
 	(else <object>)))
@@ -362,7 +361,7 @@ USA.
 		      (string-append "<" (record-type-name type) ">"))
 		     (list <record>)
 		     (record-type-field-names type))))
-    (set-class/dispatch-tag! class (record-type-dispatch-tag type))
+    (set-class/dispatch-tag! class type)
     class))
 
 (define built-in-class-table
diff --git a/src/sos/recslot.scm b/src/sos/recslot.scm
index 95c7216df..051ccad60 100644
--- a/src/sos/recslot.scm
+++ b/src/sos/recslot.scm
@@ -106,7 +106,7 @@ USA.
 (add-generic-procedure-generator %record-slot-index
   (lambda (generic tags)
     generic
-    (and (record-tag? (car tags))
+    (and (record-type? (car tags))
 	 (lambda (record name)
 	   (record-type-field-index (record-type-descriptor record)
 				    name
@@ -117,6 +117,6 @@ USA.
 (add-generic-procedure-generator %record-slot-names
   (lambda (generic tags)
     generic
-    (and (record-tag? (car tags))
+    (and (record-type? (car tags))
 	 (lambda (record)
 	   (record-type-field-names (record-type-descriptor record))))))
\ No newline at end of file