Refactor record layout following a suggestion from Taylor.

New layout is identical for records that don't have a parent type.  For those
that do have a parent type, the layout is like this:

    root-marker
    root-fields
    sub1-marker
    sub1-fields
    sub2-marker
    sub2-fields
    ...

The primary advantage of this layout is to make the record predicate be constant
time, as opposed to the previous design in which it could be linear in the depth
of the parent chain.

In addition, a number of record operations have been bummed for slightly better
performance, and the layout of record types has been altered to keep track of
the type information in a way that's better organized for generating the record
operations.

There are some behavioral changes:

* This implementation is slightly incompatible with SRFI 131, since it prohibits
  a child from having a field name that's the same as one of its ancestors.
  I'll probably change this for compatibility.

* Only a root record type can have an applicability method, and that method is
  called for all sub-types of that root type.  Arguably this is reasonable
  behavior.

* Non-root fasdumpable records must have proxy markers for all of their
  component types.  Previously, only the record type stored in slot 0 needed to
  have a fasdumpable proxy.  This isn't an immediate issue since fasdumpable
  records are used very sparingly at the moment and probably won't be supported
  outside of the runtime system.

diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 0adbefd2f156b02d743ffd17fb35849d3d38516d..4b6d817d0e28823b0557745724622540f368e04d 100644 (file)
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -37,9 +37,7 @@ USA.
 (declare (usual-integrations))
 \f
 (define (make-bundle-predicate name)
-  (let ((type (make-record-type name '() <bundle>)))
-    (set-record-type-applicator! type %bundle-applicator)
-    (record-predicate type)))
+  (record-predicate (make-record-type name '() <bundle>)))
 
 (define (%bundle-applicator bundle name . args)
   (apply (bundle-ref bundle name) args))
@@ -82,10 +80,7 @@ USA.
 
 (define <bundle>
   (make-record-type '<bundle> '(alist)))
-
-(defer-boot-action 'record-procedures
-  (lambda ()
-    (set-record-type-applicator! <bundle> %bundle-applicator)))
+(set-record-type-applicator! <bundle> %bundle-applicator)
 
 (define bundle?
   (record-predicate <bundle>))

diff --git a/src/runtime/bytevector-low.scm b/src/runtime/bytevector-low.scm
new file mode 100644 (file)
index 0000000..03a6a3b
--- /dev/null
+++ b/src/runtime/bytevector-low.scm
@@ -0,0 +1,53 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; R7RS bytevectors (early in cold-load)
+;;; package: (runtime bytevector)
+
+(declare (usual-integrations))
+\f
+(define-primitives
+  (allocate-bytevector 1)
+  (bytevector-length 1)
+  (bytevector-u8-ref 2)
+  (bytevector-u8-set! 3)
+  (bytevector? 1)
+  (integer-length-in-bits 1)
+  (legacy-string-allocate string-allocate 1)
+  (legacy-string? string? 1))
+
+(define (bytevector<? b1 b2)
+  (let ((l1 (bytevector-length b1))
+       (l2 (bytevector-length b2)))
+    (let ((end (fix:min l1 l2)))
+      (let loop ((index 0))
+       (if (fix:< index end)
+           (let ((u1 (bytevector-u8-ref b1 index))
+                 (u2 (bytevector-u8-ref b2 index)))
+             (if (fix:= u1 u2)
+                 (loop (fix:+ index 1))
+                 (fix:< u1 u2)))
+           (fix:< l1 l2))))))
\ No newline at end of file

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index c77fecfb88841f97ae5237062e98bdc7b0bc9c99..fce5ca9b3d1ba47f5a6fda972457f2b535aaabc0 100644 (file)
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -34,16 +34,6 @@ USA.
        (fix:< object #x100)))
 (register-predicate! u8? 'u8 '<= index-fixnum?)
 
-(define-primitives
-  (allocate-bytevector 1)
-  (bytevector-length 1)
-  (bytevector-u8-ref 2)
-  (bytevector-u8-set! 3)
-  (bytevector? 1)
-  (integer-length-in-bits 1)
-  (legacy-string-allocate string-allocate 1)
-  (legacy-string? string? 1))
-
 (define (make-bytevector k #!optional byte)
   (let ((bytevector (allocate-bytevector k)))
     (if (not (default-object? byte))
@@ -106,19 +96,6 @@ USA.
                           (bytevector-u8-ref b2 index))
                    (loop (fix:+ index 1))))))))
 
-(define (bytevector<? b1 b2)
-  (let ((l1 (bytevector-length b1))
-       (l2 (bytevector-length b2)))
-    (let ((end (fix:min l1 l2)))
-      (let loop ((index 0))
-       (if (fix:< index end)
-           (let ((u1 (bytevector-u8-ref b1 index))
-                 (u2 (bytevector-u8-ref b2 index)))
-             (if (fix:= u1 u2)
-                 (loop (fix:+ index 1))
-                 (fix:< u1 u2)))
-           (fix:< l1 l2))))))
-
 ;; String hash primitives work on bytevectors too.
 (define (bytevector-hash bytevector #!optional modulus)
   (if (default-object? modulus)

diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm
index 2f55f6518277956deb95e8828613ebbbb66576be..af32280370dd0063344457d4e6309a0b83c0b374 100644 (file)
--- a/src/runtime/equals.scm
+++ b/src/runtime/equals.scm
@@ -29,6 +29,9 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define-primitives
+  eq?)
+
 (define (eqv? x y)
   ;; EQV? is officially supposed to work on booleans, characters, and
   ;; numbers specially, but it turns out that EQ? does the right thing

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index b824568f3d9bdc3cab5c6030689ec3a557e2402c..95cba4129dcb1dc99f8498c203531c161657bbd0 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -48,7 +48,6 @@ USA.
   (object-type? 2)
   (object-new-type object-set-type 2)
   make-non-pointer-object
-  eq?
 
   ;; Cells
   make-cell cell? cell-contents set-cell-contents!

diff --git a/src/runtime/list.scm b/src/runtime/list.scm
index dfd9d06e5c7e714f9899514c4f0bebc6103741b0..ab9fb90cdcbe2420d4ac9e4a63b4c46b30ac2285 100644 (file)
--- a/src/runtime/list.scm
+++ b/src/runtime/list.scm
@@ -931,6 +931,10 @@ USA.
                            (= key (get-key item))))
                        (cdr items))
                   (loop (cdr items))))))))
+
+(define (list-of-unique-symbols? object)
+  (and (list-of-type? object symbol?)
+       (not (any-duplicates? object eq?))))
 \f
 ;;;; Membership lists
 

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index f870e44101bd0f9fe748e6e6b7cbd4e7ee39bb6d..a1370b6cb4fc4ba8f917f50a312cff80efe87079 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -367,7 +367,9 @@ USA.
         ("srfi-1" . (runtime srfi-1))
         ("thread-low" . (runtime thread))))
       (files1
-       '(("string" . (runtime string))
+       '(("msort" . (runtime merge-sort))
+        ("string" . (runtime string))
+        ("bytevector-low" . (runtime bytevector))
         ("symbol" . (runtime symbol))
         ("random" . (runtime random-number))
         ("dispatch-tag" . (runtime tagged-dispatch))

diff --git a/src/runtime/msort.scm b/src/runtime/msort.scm
index 70efc1eea7edd54a7662294ab9fdd9e7c07806d0..090d9b47a0893a58bc5b3d2ee9ed149f267a779a 100644 (file)
--- a/src/runtime/msort.scm
+++ b/src/runtime/msort.scm
@@ -63,7 +63,4 @@ USA.
                    (begin
                      (vector-set! v p (vector-ref temp p2))
                      (merge (fix:+ p 1) p1 (fix:+ p2 1)))))))))
-  v)
-
-(define sort merge-sort)
-(define sort! merge-sort!)
\ No newline at end of file
+  v)
\ No newline at end of file

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 8f4701f0f2fcf8a2d8588d521d837d71f58e2388..5d196187a85460c9de42fd3ce52203a1298f055d 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -43,10 +43,13 @@ USA.
        (%make-record-type type-name field-specs #f)
        (begin
          (guarantee record-type? parent-type 'make-record-type)
-         (%make-record-type type-name
-                            (append (record-type-field-specs parent-type)
-                                    field-specs)
-                            parent-type)))))
+         (for-each (lambda (field-spec)
+                     (let ((name (field-spec-name field-spec)))
+                       (if (%record-type-field-by-name-no-error parent-type
+                                                                name)
+                           (error "Duplicate child name:" name))))
+                   field-specs)
+         (%make-record-type type-name field-specs parent-type)))))
 
 (define (valid-field-specs? object)
   (and (list? object)
@@ -62,6 +65,11 @@ USA.
           (%valid-default-init? (cadr object))
           (null? (cddr object)))))
 
+(define (make-field-spec name init)
+  (if init
+      (list name init)
+      name))
+
 (define (field-spec-name spec)
   (if (pair? spec) (car spec) spec))
 
@@ -82,56 +90,74 @@ USA.
 
 (define (initialize-record-procedures!)
   (run-deferred-boot-actions 'record-procedures))
-\f
-(define (list-of-unique-symbols? object)
-  (and (list-of-type? object symbol?)
-       (let loop ((elements object))
-        (if (pair? elements)
-            (and (not (memq (car elements) (cdr elements)))
-                 (loop (cdr elements)))
-            #t))))
-
-(define (make-field-spec name init)
-  (if init
-      (list name init)
-      name))
 
+(define (->type-name object caller)
+  (cond ((string? object) (string->symbol object))
+       ((symbol? object) object)
+       (else (error:wrong-type-argument object "type name" caller))))
+\f
 (define (%make-record-type type-name field-specs parent-type)
-  (letrec*
-      ((predicate
-       (lambda (object)
-         (and (%record? object)
-              (or (eq? (%record-type-instance-marker type)
-                       (%record-ref object 0))
-                  (let ((type* (%record->type object)))
-                    (and type*
-                         (%record-type<= type* type)))))))
-       (type
-       (%%make-record-type type-name
-                           predicate
-                           (list->vector (map field-spec-name field-specs))
-                           (list->vector (map field-spec-init field-specs))
-                           parent-type
-                           #f
-                           #f)))
-    (%set-record-type-instance-marker! type type)
-    (set-predicate<=! predicate
-                     (if parent-type
-                         (record-predicate parent-type)
-                         record?))
-    type))
-
-(define (%record->type record)
-  (let ((marker (%record-ref record 0)))
-    (cond ((record-type? marker) marker)
-         ((%record-type-proxy? marker) (%proxy->record-type marker))
-         (else #f))))
-
-(define (%record-type<= t1 t2)
-  (or (eq? t1 t2)
-      (let ((parent (%record-type-parent t1)))
-       (and parent
-            (%record-type<= parent t2)))))
+  (let* ((start-index (if parent-type (%record-type-end-index parent-type) 0))
+        (end-index (+ start-index 1 (length field-specs)))
+        (partial-fields
+         (list->vector
+          (map (lambda (spec index)
+                 (make-field (field-spec-name spec)
+                             (field-spec-init spec)
+                             index))
+               field-specs
+               (iota (length field-specs) (+ start-index 1)))))
+        (fields-by-index
+         (if parent-type
+             (vector-append (%record-type-fields-by-index parent-type)
+                            partial-fields)
+             partial-fields)))
+
+    (letrec*
+       ((predicate
+         (if parent-type
+             (lambda (object)
+               (and (%record? object)
+                    (fix:>= (%record-length object) end-index)
+                    (eq? (%record-type-instance-marker type)
+                         (%record-ref object start-index))))
+             (lambda (object)
+               (and (%record? object)
+                    (eq? (%record-type-instance-marker type)
+                         (%record-ref object 0))))))
+        (type
+         (%%make-record-type type-name
+                             predicate
+                             start-index
+                             end-index
+                             fields-by-index
+                             (let ((v (vector-copy fields-by-index)))
+                               (sort! v
+                                      (lambda (f1 f2)
+                                        (symbol<? (field-name f1)
+                                                  (field-name f2))))
+                               v)
+                             parent-type
+                             #f
+                             #f)))
+      (%set-record-type-instance-marker! type type)
+      (set-predicate<=! predicate
+                       (if parent-type
+                           (record-predicate parent-type)
+                           record?))
+      type)))
+
+(define-integrable (make-field name init index)
+  (vector name init index))
+
+(define-integrable (field-name field)
+  (vector-ref field 0))
+
+(define-integrable (field-init field)
+  (vector-ref field 1))
+
+(define-integrable (field-index field)
+  (vector-ref field 2))
 \f
 (define %record-metatag)
 (define record-type?)
@@ -144,82 +170,121 @@ USA.
         (dispatch-metatag-constructor %record-metatag 'make-record-type))
    unspecific))
 
-(define-integrable (%record-type-field-names record-type)
-  (dispatch-tag-extra-ref record-type 0))
+(define-integrable (%record-type-start-index record-type)
+  (%dispatch-tag-extra-ref record-type 0))
 
-(define-integrable (%record-type-default-inits record-type)
-  (dispatch-tag-extra-ref record-type 1))
+(define-integrable (%record-type-end-index record-type)
+  (%dispatch-tag-extra-ref record-type 1))
+
+(define-integrable (%record-type-fields-by-index record-type)
+  (%dispatch-tag-extra-ref record-type 2))
+
+(define-integrable (%record-type-fields-by-name record-type)
+  (%dispatch-tag-extra-ref record-type 3))
 
 (define-integrable (%record-type-parent record-type)
-  (dispatch-tag-extra-ref record-type 2))
+  (%dispatch-tag-extra-ref record-type 4))
 
 (define-integrable (%record-type-instance-marker record-type)
-  (%dispatch-tag-extra-ref record-type 3))
+  (%dispatch-tag-extra-ref record-type 5))
 
 (define-integrable (%set-record-type-instance-marker! record-type marker)
-  (%dispatch-tag-extra-set! record-type 3 marker))
+  (%dispatch-tag-extra-set! record-type 5 marker))
 
 (define-integrable (%record-type-applicator record-type)
-  (dispatch-tag-extra-ref record-type 4))
+  (%dispatch-tag-extra-ref record-type 6))
 
 (define-integrable (%set-record-type-applicator! record-type applicator)
-  (%dispatch-tag-extra-set! record-type 4 applicator))
+  (%dispatch-tag-extra-set! record-type 6 applicator))
 
 (defer-boot-action 'fixed-objects
   (lambda ()
     (set-fixed-objects-item! 'record-dispatch-tag %record-metatag)
     (set-fixed-objects-item! 'record-applicator-index
-                            (%dispatch-tag-extra-index 4))))
-
-(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)))
-
+                            (%dispatch-tag-extra-index 6))))
+
+(define (%record-type-field-by-name record-type name)
+  (or (%record-type-field-by-name-no-error record-type name)
+      (%record-type-field-by-name record-type
+                                 (error:no-such-slot record-type name))))
+
+(define-integrable (%record-type-field-by-name-no-error record-type name)
+  (vector-binary-search (%record-type-fields-by-name record-type)
+                       symbol<?
+                       field-name
+                       name))
+
+(define (%record-type-field-by-index record-type index)
+  (or (%record-type-field-by-index-no-error record-type index)
+      (%record-type-field-by-index record-type
+                                  (error:no-such-slot record-type index))))
+
+(define-integrable (%record-type-field-by-index-no-error record-type index)
+  (vector-binary-search (%record-type-fields-by-index record-type)
+                       fix:<
+                       field-index
+                       index))
+\f
 (define (record-type-name record-type)
   (guarantee record-type? record-type 'record-type-name)
-  (symbol->string (dispatch-tag-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)
-  (vector->list (%record-type-field-names record-type)))
+  (%record-type-field-names record-type))
+
+(define (%record-type-field-names record-type)
+  (%map-record-type-fields field-name
+                          (%record-type-fields-by-index record-type)))
 
 (define (record-type-field-specs record-type)
   (guarantee record-type? record-type 'record-type-field-specs)
-  (map make-field-spec
-       (vector->list (%record-type-field-names record-type))
-       (vector->list (%record-type-default-inits record-type))))
+  (%map-record-type-fields (lambda (field)
+                            (make-field-spec (field-name field)
+                                             (field-init field)))
+                          (%record-type-fields-by-index record-type)))
+
+(define (%map-record-type-fields procedure fields)
+  (let loop ((i (fix:- (vector-length fields) 1)) (tail '()))
+    (if (fix:>= i 0)
+       (loop (fix:- i 1)
+             (cons (procedure (vector-ref fields i))
+                   tail))
+       tail)))
+
+(define (record-type-field-index record-type name)
+  (guarantee record-type? record-type 'record-type-field-index)
+  (guarantee symbol? name 'record-type-field-index)
+  (let ((field (%record-type-field-by-name-no-error record-type name)))
+    (and field
+        (field-index field))))
 
 (define (record-type-parent record-type)
   (guarantee record-type? record-type 'record-type-parent)
   (%record-type-parent record-type))
 
-(define (set-record-type-applicator! record-type applicator)
-  (guarantee record-type? record-type 'set-record-type-applicator!)
-  (guarantee procedure? applicator 'set-record-type-applicator!)
-  (%set-record-type-applicator! record-type applicator))
-
-(define (record-applicator record)
-  (or (%record-type-applicator (record-type-descriptor record))
-      (error:not-a applicable-record? record 'record-applicator)))
-\f
-(define (record? object)
-  (and (%record? object)
-       (%record->type object)
-       #t))
-
 (define (applicable-record? object)
+  (and (%record->applicator object) #t))
+
+(define (%record->applicator object)
   (and (%record? object)
-       (let ((record-type (%record->type object)))
+       (let ((record-type (%record->root-type object)))
         (and record-type
-             (%record-type-applicator record-type)
-             #t))))
+             (%record-type-applicator record-type)))))
 
-(define (record-type-descriptor record)
-  (or (%record->type record)
-      (error:not-a record? record 'record-type-descriptor)))
+(define (record-applicator record)
+  (let ((applicator (%record->applicator record)))
+    (if (not applicator)
+       (error:not-a applicable-record? record 'record-applicator))
+    applicator))
 
+(define (set-record-type-applicator! record-type applicator)
+  (guarantee record-type? record-type 'set-record-type-applicator!)
+  (if (%record-type-parent record-type)
+      (error:bad-range-argument record-type 'set-record-type-applicator!))
+  (guarantee procedure? applicator 'set-record-type-applicator!)
+  (%set-record-type-applicator! record-type applicator))
+\f
 (define (%record-type-fasdumpable? type)
   (%record-type-proxy? (%record-type-instance-marker type)))
 
@@ -282,17 +347,69 @@ USA.
                   (iota (length (cdr form)))))))))
   (enumerate-proxies pathname host))
 \f
-;;;; Constructors
+(define (record? object)
+  (and (%record? object)
+       (%record->root-type object)
+       #t))
 
+(define (record-type-descriptor record)
+  (guarantee record? record 'record-type-descriptor)
+  (%record->leaf-type record))
+
+(define-integrable (%record->root-type record)
+  (%record-type-ref record 0))
+
+(define (%record->leaf-type record)
+  (let loop ((type (%record-type-ref record 0)))
+    (let ((type*
+          (let ((end (%record-type-end-index type)))
+            (and (fix:> (%record-length record) end)
+                 (%record-type-ref type end)))))
+      (if type*
+         (loop type*)
+         type))))
+
+(define (%record-type-ref record index)
+  (let ((marker (%record-ref record index)))
+    (cond ((record-type? marker) marker)
+         ((%record-type-proxy? marker) (%proxy->record-type marker))
+         (else #f))))
+\f
 (define (record-constructor record-type #!optional field-names)
   (guarantee record-type? record-type 'record-constructor)
   (if (or (default-object? field-names)
-         (equal? field-names (record-type-field-names record-type)))
+         (%default-field-names? record-type field-names))
       (%record-constructor-default-names record-type)
       (begin
        (guarantee list? field-names 'record-constructor)
+       (if (any-duplicates? field-names eq?)
+           (error:bad-range-argument field-names 'record-constructor))
        (%record-constructor-given-names record-type field-names))))
 
+(define (%default-field-names? record-type field-names)
+  (let* ((fields (%record-type-fields-by-index record-type))
+        (n-fields (vector-length fields)))
+    (let loop ((names field-names) (i 0))
+      (if (and (pair? names) (fix:< i n-fields))
+         (and (eq? (car names) (field-name (vector-ref fields i)))
+              (loop (cdr names) (fix:+ i 1)))
+         (and (null? names) (fix:= i n-fields))))))
+
+(define (%typed-record-maker record-type)
+  (if (%record-type-parent record-type)
+      (lambda ()
+       (let ((record (%make-record #f (%record-type-end-index record-type))))
+         (let loop ((type record-type))
+           (%record-set! record
+                         (%record-type-start-index type)
+                         (%record-type-instance-marker type))
+           (if (%record-type-parent type)
+               (loop (%record-type-parent type))))
+         record))
+      (lambda ()
+       (%make-record (%record-type-instance-marker record-type)
+                     (%record-type-end-index record-type)))))
+
 (define %record-constructor-default-names
   (let-syntax
       ((expand-cases
@@ -314,108 +431,112 @@ USA.
                               (append names (list (make-name i)))))
                   default)))))))
     (lambda (record-type)
-      (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
-                           (%record-type-instance-marker record-type)
-                           reclen))
-                         (lose
-                          (lambda ()
-                            (error:wrong-number-of-arguments constructor
-                                                             n-fields
-                                                             field-values))))
-                     (do ((i 1 (fix:+ i 1))
-                          (vals field-values (cdr vals)))
-                         ((not (fix:< i reclen))
-                          (if (not (null? vals)) (lose)))
-                       (if (not (pair? vals)) (lose))
-                       (%record-set! record i (car vals)))
-                     record))))
-             constructor)))))))
+      (let* ((indices
+             (vector-map field-index
+                         (%record-type-fields-by-index record-type)))
+            (arity (vector-length indices))
+            (%make-typed-record (%typed-record-maker record-type)))
+
+       (define (general-case)
+         (define (constructor . field-values)
+           (if (not (fix:= arity (length field-values)))
+               (error:wrong-number-of-arguments constructor
+                                                arity
+                                                field-values))
+
+           (let ((record (%make-typed-record)))
+             (do ((i 0 (fix:+ i 1))
+                  (vals field-values (cdr vals)))
+                 ((not (fix:< i arity)) unspecific)
+               (%record-set! record
+                             (vector-ref indices i)
+                             (car vals)))
+             record))
+         constructor)
+
+       (if (%record-type-parent record-type)
+           (general-case)
+           (expand-cases record-type arity 16
+                         (general-case)))))))
 \f
 (define (%record-constructor-given-names record-type field-names)
-  (let* ((indexes
+  (let* ((fields
          (map (lambda (field-name)
-                (record-type-field-index record-type field-name #t))
+                (%record-type-field-by-name record-type field-name))
               field-names))
         (defaults
-          (let* ((n (%record-type-length record-type))
-                 (seen? (vector-cons n #f)))
-            (do ((indexes indexes (cdr indexes)))
-                ((not (pair? indexes)))
-              (vector-set! seen? (car indexes) #t))
-            (do ((i 1 (fix:+ i 1))
-                 (k 0 (if (vector-ref seen? i) k (fix:+ k 1))))
-                ((not (fix:< i n))
-                 (let ((v (vector-cons k #f)))
-                   (do ((i 1 (fix:+ i 1))
-                        (j 0
-                           (if (vector-ref seen? i)
-                               j
-                               (begin
-                                 (vector-set! v j i)
-                                 (fix:+ j 1)))))
-                       ((not (fix:< i n))))
-                   v))))))
-    (letrec
-       ((constructor
-         (lambda field-values
-           (let ((lose
-                  (lambda ()
-                    (error:wrong-number-of-arguments constructor
-                                                     (length indexes)
-                                                     field-values))))
-             (let ((record
-                    (%make-record
-                     (%record-type-instance-marker record-type)
-                     (%record-type-length record-type))))
-               (do ((indexes indexes (cdr indexes))
-                    (values field-values (cdr values)))
-                   ((not (pair? indexes))
-                    (if (not (null? values)) (lose)))
-                 (if (not (pair? values)) (lose))
-                 (%record-set! record (car indexes) (car values)))
-               (let ((v (%record-type-default-inits record-type))
-                     (n (vector-length defaults)))
-                 (do ((i 0 (fix:+ i 1)))
-                     ((not (fix:< i n)))
-                   (let* ((index (vector-ref defaults i))
-                          (init (vector-ref v (fix:- index 1))))
-                     (and init (%record-set! record index (init))))))
-               record)))))
-      constructor)))
+         (list->vector
+          (filter field-init
+                  (lset-difference
+                   eq?
+                   (vector->list
+                    (%record-type-fields-by-index record-type))
+                   fields))))
+        (indices (list->vector (map field-index fields)))
+        (arity (vector-length indices))
+        (%make-typed-record (%typed-record-maker record-type)))
+
+    (define (constructor . field-values)
+      (if (not (fix:= arity (length field-values)))
+         (error:wrong-number-of-arguments constructor arity field-values))
+
+      (let ((record (%make-typed-record)))
+
+       (do ((i 0 (fix:+ i 1))
+            (vals field-values (cdr vals)))
+           ((not (fix:< i arity)) unspecific)
+         (%record-set! record (vector-ref indices i) (car vals)))
+
+       (let ((n (vector-length defaults)))
+         (do ((i 0 (fix:+ i 1)))
+             ((not (fix:< i n)) unspecific)
+           (let ((field (vector-ref defaults i)))
+             (%record-set! record
+                           (field-index field)
+                           ((field-init field))))))
+       record))
+
+    constructor))
 
 (define (record-keyword-constructor record-type)
-  (letrec
-      ((constructor
-       (lambda keyword-list
-         (let ((n (%record-type-length record-type)))
-           (let ((record
-                  (%make-record (%record-type-instance-marker record-type) n))
-                 (seen? (vector-cons n #f)))
-             (do ((kl keyword-list (cddr kl)))
-                 ((not (and (pair? kl)
-                            (symbol? (car kl))
-                            (pair? (cdr kl))))
-                  (if (not (null? kl))
-                      (error:not-a keyword-list? keyword-list constructor)))
-               (let ((i (record-type-field-index record-type (car kl) #t)))
-                 (if (not (vector-ref seen? i))
-                     (begin
-                       (%record-set! record i (cadr kl))
-                       (vector-set! seen? i #t)))))
-             (let ((v (%record-type-default-inits record-type)))
-               (do ((i 1 (fix:+ i 1)))
-                   ((not (fix:< i n)))
-                 (if (not (vector-ref seen? i))
-                     (let ((init (vector-ref v (fix:- i 1))))
-                       (and init (%record-set! record i (init)))))))
-             record)))))
+  (guarantee record-type? record-type 'record-keyword-constructor)
+  (let ((names (%record-type-field-names record-type))
+       (%make-typed-record (%typed-record-maker record-type)))
+
+    (define (constructor . keyword-list)
+      (if (not (restricted-keyword-list? keyword-list names))
+         (error:not-a keyword-list? keyword-list constructor))
+
+      (let ((record (%make-typed-record))
+           (all-fields
+            (cons #f
+                  (vector->list (%record-type-fields-by-index record-type)))))
+
+       (define (set-value! name value)
+         (let loop ((fields (cdr all-fields)) (prev all-fields))
+           (if (pair? fields)
+               (if (eq? name (field-name (car fields)))
+                   (begin
+                     (%record-set! record (field-index (car fields)) value)
+                     (set-cdr! prev (cdr fields)))
+                   (loop (cdr fields) fields))
+               (error "Duplicate keyword:" name))))
+
+       (do ((kl keyword-list (cddr kl)))
+           ((not (pair? kl)) unspecific)
+         (set-value! (car kl) (cadr kl)))
+
+       (let loop ((fields (cdr all-fields)))
+         (if (pair? fields)
+             (begin
+               (if (field-init (car fields))
+                   (%record-set! record
+                                 (field-index (car fields))
+                                 ((field-init (car fields)))))
+               (loop (cdr fields)))))
+
+       record))
+
     constructor))
 \f
 (define (copy-record record)
@@ -426,18 +547,19 @@ USA.
   (let ((length (%record-length record)))
     (let ((result (%make-record (%record-ref record 0) length)))
       (do ((index 1 (fix:+ index 1)))
-         ((fix:= index length))
+         ((not (fix:< index length)) unspecific)
        (%record-set! result index (%record-ref record index)))
       result)))
 
 (define (record-predicate record-type)
   (guarantee record-type? record-type 'record-predicate)
-  (dispatch-tag->predicate record-type))
+  (%dispatch-tag->predicate record-type))
 
 (define (record-accessor record-type field-name)
   (guarantee record-type? record-type 'record-accessor)
   (let ((predicate (record-predicate record-type))
-       (index (record-type-field-index record-type field-name #t)))
+       (index
+        (field-index (%record-type-field-by-name record-type field-name))))
     (let-syntax
        ((expand-cases
          (sc-macro-transformer
@@ -460,7 +582,8 @@ USA.
 (define (record-modifier record-type field-name)
   (guarantee record-type? record-type 'record-modifier)
   (let ((predicate (record-predicate record-type))
-       (index (record-type-field-index record-type field-name #t)))
+       (index
+        (field-index (%record-type-field-by-name record-type field-name))))
     (let-syntax
        ((expand-cases
          (sc-macro-transformer
@@ -480,31 +603,6 @@ USA.
                     (gen-accessor 'index))))))))
       (expand-cases 16))))
 \f
-(define record-copy copy-record)
-(define record-updater record-modifier)
-
-(define (record-type-field-index record-type name error?)
-  (let ((names (%record-type-field-names record-type)))
-    ;; Search from end because a child field must override an ancestor field of
-    ;; the same name.
-    (let loop ((i (fix:- (vector-length names) 1)))
-      (if (fix:>= i 0)
-         (if (eq? (vector-ref names i) name)
-             (fix:+ i 1)
-             (loop (fix:- i 1)))
-         (and error?
-              (record-type-field-index record-type
-                                       (error:no-such-slot record-type name)
-                                       error?))))))
-
-(define (->type-name object caller)
-  (cond ((string? object) (string->symbol object))
-       ((symbol? object) object)
-       (else (error:wrong-type-argument object "type name" caller))))
-
-(define-guarantee record-type "record type")
-(define-guarantee record "record")
-\f
 ;;;; Printing
 
 (define-print-method %record?
@@ -658,9 +756,9 @@ USA.
   ((structure-type/default-init-by-index type field-name-index)))
 
 (define (record-type-default-value-by-index record-type field-index)
+  (guarantee record-type? record-type 'record-type-default-value-by-index)
   (let ((init
-        (vector-ref (%record-type-default-inits record-type)
-                    (fix:- field-index 1))))
+        (field-init (%record-type-field-by-index record-type field-index))))
     (and init
         (init))))
 \f
@@ -677,7 +775,7 @@ USA.
              (vector-set! v 0 tag))
          (let ((seen? (make-vector n #f)))
            (do ((args arguments (cddr args)))
-               ((not (pair? args)))
+               ((not (pair? args)) unspecific)
              (if (not (pair? (cdr args)))
                  (error:not-a keyword-list? arguments #f))
              (let ((field-name (car args)))
@@ -693,7 +791,7 @@ USA.
                            (vector-set! seen? i #t)))
                      (loop (fix:+ i 1))))))
            (do ((i 0 (fix:+ i 1)))
-               ((not (fix:< i n)))
+               ((not (fix:< i n)) unspecific)
              (if (not (vector-ref seen? i))
                  (let ((init (vector-ref inits i)))
                    (and init (vector-set! v (vector-ref indexes i) (init)))))))
@@ -839,12 +937,11 @@ USA.
   unspecific)
 \f
 (define (%record-field-name record index)
-  (or (and (fix:> index 0)
-          (record? record)
-          (let ((names
-                 (%record-type-field-names (record-type-descriptor record))))
-            (and (fix:<= index (vector-length names))
-                 (vector-ref names (fix:- index 1)))))
+  (or (let ((type (and (record? record) (%record->leaf-type record))))
+       (and type
+            (let ((field (%record-type-field-by-index-no-error type index)))
+              (and field
+                   (field-name field)))))
       index))
 
 (define (store-value-restart location k thunk)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c6f3bc0c842b332f38bb44974060d663ae7a602e..de96e95beb35b714e0d62578833557abb9a079b1 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -240,6 +240,7 @@ USA.
   (files "equals")
   (parent (runtime))
   (export ()
+         eq?
          equal-hash
          equal?
          eqv?))
@@ -572,7 +573,6 @@ USA.
          ephemeron-datum
          ephemeron-key
          ephemeron?
-         eq?
          error-procedure
          eval
          exit                          ;R7RS
@@ -675,10 +675,10 @@ USA.
   (files "msort")
   (parent (runtime))
   (export ()
+         (sort merge-sort)
+         (sort! merge-sort!)
          merge-sort
-         merge-sort!
-         sort
-         sort!))
+         merge-sort!))
 
 (define-package (runtime quick-sort)
   (files "qsort")
@@ -1187,7 +1187,7 @@ USA.
          (string-slice? slice?)))
 
 (define-package (runtime bytevector)
-  (files "bytevector")
+  (files "bytevector-low" "bytevector")
   (parent (runtime))
   (export deprecated ()
          legacy-string->bytevector)
@@ -3130,6 +3130,7 @@ USA.
          list-head
          list-of-type?
          list-of-type?->length
+         list-of-unique-symbols?
          list-ref
          list-set!
          list-tail                     ;use SRFI-1 drop
@@ -3924,7 +3925,8 @@ USA.
   (files "record")
   (parent (runtime))
   (export deprecated ()
-         (new-make-record-type make-record-type) ;RELNOTE: delete
+         (record-copy copy-record)
+         (record-updater record-modifier)
          set-record-type-unparser-method!)
   (export ()
          applicable-record?
@@ -3938,7 +3940,6 @@ USA.
          define-structure/list-modifier
          define-structure/vector-accessor
          define-structure/vector-modifier
-         list-of-unique-symbols?
          make-define-structure-type
          make-record-type
          named-list?
@@ -3948,7 +3949,6 @@ USA.
          record-accessor
          record-applicator
          record-constructor
-         record-copy
          record-keyword-constructor
          record-modifier
          record-predicate
@@ -3959,7 +3959,6 @@ USA.
          record-type-name
          record-type-parent
          record-type?
-         record-updater
          record?
          set-record-type-applicator!)
   (export (runtime)
@@ -5393,9 +5392,11 @@ USA.
          probe-cache-3
          probe-cache-4)
   (export (runtime record)
+         %dispatch-tag->predicate
          %dispatch-tag-extra-index
          %dispatch-tag-extra-ref
-         %dispatch-tag-extra-set!))
+         %dispatch-tag-extra-set!
+         %dispatch-tag-name))
 
 (define-package (runtime crypto)
   (files "crypto")

diff --git a/src/sos/recslot.scm b/src/sos/recslot.scm
index c50fb3ab67d81b46bedfe60390a303b99764f8ec..9bd32f9c83d09fb7a8ffc42d41507a53814592a2 100644 (file)
--- a/src/sos/recslot.scm
+++ b/src/sos/recslot.scm
@@ -109,8 +109,7 @@ USA.
     (and (record-type? (car tags))
         (lambda (record name)
           (record-type-field-index (record-type-descriptor record)
-                                   name
-                                   #f)))))
+                                   name)))))
 (define %record-slot-names
   (make-generic-procedure 1 '%record-slot-names))