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 4125e45d8d55b5fca0713546d048359409720bd9..64bea8082dcae670b111247a9d09f2d94afa970f 100644 (file)
--- 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 39fc9901ea676532682a8adf0efad9fe0f25e9d7..29364bc439409bad3551de50bfc937cd1b1b6d1c 100644 (file)
--- 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 5b68da592ed6d36112bef47429fa32fa30234ff6..0f3a07c68a768c534fa4c35e89ec1a1d383d967f 100644 (file)
--- 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 aa21b55a152f7e771100c8a9ff20e1e93f0a9e87..c9c3e29d3e29b31e4c26776585ef366c5d4ab276 100644 (file)
--- 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)
 \f
-(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.
 \f
 (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 1be5fcac80d73886f9c71d99a8d61772b1f6ead0..36928f0dee19d656e4e8419495e4330d1b31581b 100644 (file)
--- 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 d734af1cd02eb3492983410f8f7f8650332847bb..d04dc2a2c69ed1c2300687e8d3c86481bfeb2498 100644 (file)
--- 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 95c7216df2cbfa9045cf83aefc5c4d376a843ac1..051ccad60c40d7a8c07ef2b97f9f16e2d7726802 100644 (file)
--- 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