[Guile-commits] 06/06: Rebase R6RS records on top of core records

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 73d0a3bccb3c2b79d7f0e3aaca88a84f3a5c3f43
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 29 11:30:41 2019 +0100

    Rebase R6RS records on top of core records
    
    * module/ice-9/boot-9.scm (record-type-uid): New accessor.
      (make-record-type): Record UID in record type properties.
    * module/rnrs/conditions.scm (define-condition-type): Fix invalid
      invocation of make-record-type.
    * module/rnrs/records/inspection.scm: Rewrite to use core record
      inspection facilities.
    * module/rnrs/records/procedural.scm: Rewrite to use core
      make-record-type.  Incidentally the result is that instances of
      derived R6RS record types are now flat instead of nested.
    * test-suite/tests/r6rs-records-procedural.test
      ("make-record-type-descriptor"): Relax a couple condition type checks,
      while we redo the exception system.
---
 module/ice-9/boot-9.scm                       |   6 +-
 module/rnrs/conditions.scm                    |  27 +--
 module/rnrs/records/inspection.scm            |  74 +++---
 module/rnrs/records/procedural.scm            | 322 ++++++++++----------------
 test-suite/tests/r6rs-records-procedural.test |  11 +-
 5 files changed, 183 insertions(+), 257 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index db21c69..dcff0ed 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1229,6 +1229,8 @@ VALUE."
   (assq-ref (record-type-properties rtd) 'extensible?))
 (define (record-type-opaque? rtd)
   (assq-ref (record-type-properties rtd) 'opaque?))
+(define (record-type-uid rtd)
+  (assq-ref (record-type-properties rtd) 'uid))
 
 (define (record-type-parents rtd)
   (unless (record-type? rtd)
@@ -1384,7 +1386,9 @@ VALUE."
     (let ((maybe-acons (lambda (k v tail)
                          (if v (acons k v tail) tail))))
       (maybe-acons 'extensible? extensible?
-                   (maybe-acons 'opaque? opaque? '()))))
+                   (maybe-acons 'opaque? opaque?
+                                (maybe-acons 'uid uid
+                                             '())))))
 
   (cond
    ((and uid (hashq-ref prefab-record-types uid))
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index 959411b..fa2ed67 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -125,13 +125,7 @@
       ((_ condition-type supertype constructor predicate
          (field accessor) ...)
        (letrec-syntax
-          ((transform-fields
-            (syntax-rules ()
-              ((_ (f a) . rest)
-               (cons '(immutable f a) (transform-fields . rest)))
-              ((_) '())))
-
-           (generate-accessors
+          ((generate-accessors
             (syntax-rules ()
               ((_ counter (f a) . rest)
                (begin (define a 
@@ -140,16 +134,15 @@
                           (record-accessor condition-type counter)))
                       (generate-accessors (+ counter 1) . rest)))
               ((_ counter) (begin)))))
-        (begin
-          (define condition-type 
-            (make-record-type-descriptor 
-             'condition-type supertype #f #f #f 
-             (list->vector (transform-fields (field accessor) ...))))
-          (define constructor
-            (record-constructor 
-             (make-record-constructor-descriptor condition-type #f #f)))
-          (define predicate (condition-predicate condition-type))
-          (generate-accessors 0 (field accessor) ...))))))
+        (define condition-type 
+           (make-record-type-descriptor 
+            'condition-type supertype #f #f #f 
+            '#((immutable field) ...)))
+         (define constructor
+           (record-constructor 
+            (make-record-constructor-descriptor condition-type #f #f)))
+         (define predicate (condition-predicate condition-type))
+         (generate-accessors 0 (field accessor) ...)))))
 
   (define &condition (@@ (rnrs records procedural) &condition))
   (define &condition-constructor-descriptor
diff --git a/module/rnrs/records/inspection.scm 
b/module/rnrs/records/inspection.scm
index 68b78a9..052e84f 100644
--- a/module/rnrs/records/inspection.scm
+++ b/module/rnrs/records/inspection.scm
@@ -1,6 +1,6 @@
 ;;; inspection.scm --- Inspection support for R6RS records
 
-;;      Copyright (C) 2010 Free Software Foundation, Inc.
+;;      Copyright (C) 2010, 2019 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -31,51 +31,47 @@
   (import (rnrs arithmetic bitwise (6))
           (rnrs base (6))
          (rnrs records procedural (6))
-         (only (guile) struct-ref struct-vtable vtable-index-layout @@))
-
-  (define record-internal? (@@ (rnrs records procedural) record-internal?))
-
-  (define rtd-index-name (@@ (rnrs records procedural) rtd-index-name))
-  (define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent))
-  (define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid))
-  (define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?))
-  (define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?))
-  (define rtd-index-field-names 
-    (@@ (rnrs records procedural) rtd-index-field-names))
-  (define rtd-index-field-bit-field
-    (@@ (rnrs records procedural) rtd-index-field-bit-field))
+         (rename (only (guile)
+                        unless
+                        logbit?
+                        record?
+                        record-type-name
+                        record-type-parent
+                        record-type-fields
+                        record-type-opaque?
+                        record-type-extensible?
+                        record-type-uid
+                        record-type-mutable-fields
+                        struct-vtable)
+                  (record? guile:record?)))
 
   (define (record? obj)
-    (and (record-internal? obj)
+    (and (guile:record? obj)
         (not (record-type-opaque? (struct-vtable obj)))))
 
   (define (record-rtd record)
-    (or (and (record-internal? record)
-            (let ((rtd (struct-vtable record)))
-              (and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
-       (assertion-violation 'record-rtd "not a record" record)))
-
-  (define (guarantee-rtd who rtd)
-    (if (record-type-descriptor? rtd)
-        rtd
-        (assertion-violation who "not a record type descriptor" rtd)))
+    (unless (record? record)
+      (assertion-violation 'record-rtd "not a record" record))
+    (struct-vtable record))
 
-  (define (record-type-name rtd) 
-    (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
-  (define (record-type-parent rtd) 
-    (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
-  (define (record-type-uid rtd)
-    (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
   (define (record-type-generative? rtd) 
-    (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
+    (not (record-type-uid rtd)))
   (define (record-type-sealed? rtd) 
-    (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
-  (define (record-type-opaque? rtd) 
-    (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
+    (not (record-type-extensible? rtd)))
   (define (record-type-field-names rtd)
-    (struct-ref (guarantee-rtd 'record-type-field-names rtd) 
rtd-index-field-names))
+    (let ((parent (record-type-parent rtd))
+          (fields (record-type-fields rtd)))
+      (list->vector
+       (if parent
+           (list-tail fields (length (record-type-fields parent)))
+           fields))))
   (define (record-field-mutable? rtd k)
-    (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
-                                  rtd-index-field-bit-field)
-                      k))
-)
+    (let* ((parent (record-type-parent rtd))
+           (parent-nfields (if parent
+                               (length (record-type-fields parent))
+                               0))
+           (k (+ k parent-nfields)))
+      (unless (and (<= parent-nfields k)
+                   (< k (length (record-type-fields rtd))))
+        (r6rs-raise (make-assertion-violation)))
+      (logbit? k (record-type-mutable-fields rtd)))))
diff --git a/module/rnrs/records/procedural.scm 
b/module/rnrs/records/procedural.scm
index cbcd4e5..08a7fd2 100644
--- a/module/rnrs/records/procedural.scm
+++ b/module/rnrs/records/procedural.scm
@@ -19,7 +19,7 @@
 
 (library (rnrs records procedural (6))
   (export make-record-type-descriptor 
-         record-type-descriptor?
+          (rename (record-type? record-type-descriptor?))
          make-record-constructor-descriptor
          
          record-constructor
@@ -28,214 +28,140 @@
          record-mutator)
          
   (import (rnrs base (6))
-          (only (guile) cons*
-                        logand 
-                        logior
-                        ash
+    (only (rename (guile)
+                  (record-accessor guile:record-accessor))
+          cons*
+          logbit?
 
-                        and=>
-                       throw
-                       display
-                       make-struct/no-tail
-                       make-vtable 
-                       map
-                       simple-format
-                       string-append 
-                        symbol-append
-                       
-                       struct? 
-                        struct-layout
-                       struct-ref 
-                       struct-set! 
-                       struct-vtable
-                       vtable-index-layout
+          when unless
 
-                        make-hash-table
-                       hashq-ref
-                       hashq-set!
+          throw
 
-                       vector->list
+         struct-ref
+         struct-set!
 
-                        vtable-offset-user)
-         (ice-9 receive)
-         (only (srfi :1) fold split-at take))
+          make-record-type
+          record-type?
+          record-type-name
+          record-type-fields
+          record-type-constructor
+          record-type-mutable-fields
+          record-type-parent
+          record-type-opaque?
+          record-predicate
+          guile:record-accessor
+          record-modifier
 
-  (define (record-internal? obj)
-    (and (struct? obj) (record-type-descriptor? (struct-vtable obj))))
-
-  (define rtd-index-name            (+ vtable-offset-user 0))
-  (define rtd-index-uid             (+ vtable-offset-user 1))
-  (define rtd-index-parent          (+ vtable-offset-user 2))
-  (define rtd-index-sealed?         (+ vtable-offset-user 3))
-  (define rtd-index-opaque?         (+ vtable-offset-user 4))
-  (define rtd-index-predicate       (+ vtable-offset-user 5))
-  (define rtd-index-field-names     (+ vtable-offset-user 6))
-  (define rtd-index-field-bit-field (+ vtable-offset-user 7))
-  (define rtd-index-field-binder    (+ vtable-offset-user 8))
-
-  (define rctd-index-rtd 0)
-  (define rctd-index-parent 1)
-  (define rctd-index-protocol 2)
-
-  (define vtable-base-layout (symbol->string (struct-layout (make-vtable ""))))
-
-  (define record-type-vtable 
-    (make-vtable (string-append vtable-base-layout "pwpwpwpwpwpwpwpwpwpw")
-                (lambda (obj port) 
-                  (simple-format port "#<r6rs:record-type:~A>"
-                                 (struct-ref obj rtd-index-name)))))
-
-  (define record-constructor-vtable 
-    (make-vtable "pwpwpw"
-                (lambda (obj port) 
-                  (simple-format port "#<r6rs:record-constructor:~A>" 
-                                 (struct-ref (struct-ref obj rctd-index-rtd)
-                                             rtd-index-name)))))
-
-  (define uid-table (make-hash-table))    
+          vector->list))
 
   (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
-    (define fields-pair
-      (let loop ((field-list (vector->list fields))
-                 (layout-sym 'pw)
-                 (layout-bit-field 0)
-                 (counter 0))
-        (if (null? field-list)
-            (cons layout-sym layout-bit-field)
-            (case (caar field-list)
-              ((immutable) 
-               (loop (cdr field-list)
-                     (symbol-append layout-sym 'pw)
-                     layout-bit-field 
-                     (+ counter 1)))
-              ((mutable)
-               (loop (cdr field-list)
-                     (symbol-append layout-sym 'pw)
-                     (logior layout-bit-field (ash 1 counter))
-                     (+ counter 1)))
-              (else (r6rs-raise (make-assertion-violation)))))))
-
-    (define fields-layout (car fields-pair))
-    (define fields-bit-field (cdr fields-pair))
-
-    (define field-names (list->vector (map cadr (vector->list fields))))
-    (define late-rtd #f)
-
-    (define (private-record-predicate obj)       
-      (and (record-internal? obj)
-           (or (eq? (struct-vtable obj) late-rtd)
-               (and=> (struct-ref obj 0) private-record-predicate))))
-
-    (define (field-binder parent-struct . args)
-      (apply make-struct/no-tail late-rtd parent-struct args))
-
-    (if (and parent (struct-ref parent rtd-index-sealed?))
-       (r6rs-raise (make-assertion-violation)))
-
-    (let ((matching-rtd (and uid (hashq-ref uid-table uid)))
-         (opaque? (or opaque? (and parent (struct-ref 
-                                           parent rtd-index-opaque?)))))
-      (if matching-rtd
-         (if (equal? (list name 
-                           parent 
-                           sealed? 
-                           opaque?                            
-                           field-names
-                            fields-bit-field)
-                     (list (struct-ref matching-rtd rtd-index-name)
-                           (struct-ref matching-rtd rtd-index-parent)
-                           (struct-ref matching-rtd rtd-index-sealed?)
-                           (struct-ref matching-rtd rtd-index-opaque?)
-                           (struct-ref matching-rtd rtd-index-field-names)
-                            (struct-ref matching-rtd 
-                                        rtd-index-field-bit-field)))
-             matching-rtd
-             (r6rs-raise (make-assertion-violation)))
-          
-         (let ((rtd (make-struct/no-tail
-                      record-type-vtable
-
-                      fields-layout
-                      (lambda (obj port)
-                        (simple-format 
-                         port "#<r6rs:record:~A>" name))
-                                 
-                      name
-                      uid
-                      parent 
-                      sealed? 
-                      opaque?
-                                 
-                      private-record-predicate
-                      field-names
-                      fields-bit-field
-                      field-binder)))
-           (set! late-rtd rtd)
-           (if uid (hashq-set! uid-table uid rtd))
-           rtd))))
-
-  (define (record-type-descriptor? obj)
-    (and (struct? obj) (eq? (struct-vtable obj) record-type-vtable)))
-
-  (define (make-record-constructor-descriptor rtd 
-                                             parent-constructor-descriptor
-                                             protocol)
-    (define rtd-arity (vector-length (struct-ref rtd rtd-index-field-names)))
-    (define (default-inherited-protocol n)
-      (lambda args
-       (receive 
-          (n-args p-args) 
-         (split-at args (- (length args) rtd-arity))
-         (let ((p (apply n n-args)))
-           (apply p p-args)))))
-    (define (default-protocol p) p)
-    
-    (let* ((prtd (struct-ref rtd rtd-index-parent))
-          (pcd (or parent-constructor-descriptor
-                   (and=> prtd (lambda (d) (make-record-constructor-descriptor 
-                                            prtd #f #f)))))
-          (prot (or protocol (if pcd 
-                                 default-inherited-protocol 
-                                 default-protocol))))
-      (make-struct/no-tail record-constructor-vtable rtd pcd prot)))
-
-  (define (record-constructor rctd)
-    (let* ((rtd (struct-ref rctd rctd-index-rtd))
-          (parent-rctd (struct-ref rctd rctd-index-parent))
-          (protocol (struct-ref rctd rctd-index-protocol)))
-      (protocol 
-       (if parent-rctd
-          (let ((parent-record-constructor (record-constructor parent-rctd))
-                (parent-rtd (struct-ref parent-rctd rctd-index-rtd)))
-            (lambda args
-              (let ((struct (apply parent-record-constructor args)))
-                (lambda args
-                  (apply (struct-ref rtd rtd-index-field-binder)
-                         (cons struct args))))))
-          (lambda args (apply (struct-ref rtd rtd-index-field-binder)
-                              (cons #f args)))))))
+    (make-record-type name (vector->list fields) #:parent parent #:uid uid
+                      #:extensible? (not sealed?)
+                      #:opaque? (or opaque?
+                                    (and parent (record-type-opaque? 
parent)))))
+
+  (define record-constructor-descriptor
+    (make-record-type 'record-constructor-descriptor
+                      '((immutable rtd)
+                        (immutable parent)
+                        (immutable protocol))))
+  (define rcd-rtd
+    (guile:record-accessor record-constructor-descriptor 'rtd))
+  (define rcd-parent
+    (guile:record-accessor record-constructor-descriptor 'parent))
+  (define rcd-protocol
+    (guile:record-accessor record-constructor-descriptor 'protocol))
+
+  (define (make-record-constructor-descriptor rtd parent-rcd protocol)
+    (unless (record-type? rtd)
+      (r6rs-raise (make-assertion-violation)))
+    (when protocol
+      (unless (procedure? protocol)
+        (r6rs-raise (make-assertion-violation))))
+    (when parent-rcd
+      (unless (eq? (rcd-rtd parent-rcd)
+                   (record-type-parent rtd))
+        (when protocol
+          (r6rs-raise (make-assertion-violation)))))
+    ((record-type-constructor record-constructor-descriptor)
+     rtd parent-rcd protocol))
+
+  (define (record-constructor rcd)
+    ;; The protocol facility allows users to define constructors whose
+    ;; arguments don't directly correspond to the fields of the record
+    ;; type; instead, the protocol managed a mapping from "args" to
+    ;; "inits", where args are constructor args, and inits are the
+    ;; resulting set of initial field values.
+    (define-syntax if*
+      (syntax-rules (=>)
+        ((if* (exp => id) consequent alternate)
+         (cond (exp => (lambda (id) consequent)) (else alternate)))))
+    (define raw-constructor
+      (record-type-constructor (rcd-rtd rcd)))
+    (if* ((rcd-protocol rcd) => protocol)
+         (protocol
+          (if* ((rcd-parent rcd) => parent)
+               (lambda parent-args
+                 (lambda inits
+                   (let collect-inits ((parent parent)
+                                       (parent-args parent-args)
+                                       (inits inits))
+                     (apply
+                      (if* ((and parent (rcd-protocol parent)) => protocol)
+                           (protocol
+                            (if* ((rcd-parent parent) => parent)
+                                 ;; Parent has a protocol too; collect
+                                 ;; inits from parent.
+                                 (lambda parent-args
+                                   (lambda parent-inits
+                                     (collect-inits parent parent-args
+                                                    (append parent-inits
+                                                            inits))))
+                                 ;; Default case: parent args correspond
+                                 ;; to inits.
+                                 (lambda parent-args
+                                   (apply raw-constructor
+                                          (append parent-args inits)))))
+                           ;; Default case: parent args correspond to inits.
+                           (lambda parent-args
+                             (apply raw-constructor
+                                    (append parent-args inits))))
+                      parent-args))))
+               raw-constructor))
+         raw-constructor))
                    
-  (define (record-predicate rtd) (struct-ref rtd rtd-index-predicate))
-
   (define (record-accessor rtd k)
-    (define (record-accessor-inner obj)
-      (if (eq? (struct-vtable obj) rtd)
-         (struct-ref obj (+ k 1))
-          (and=> (struct-ref obj 0) record-accessor-inner)))
-    (lambda (obj) 
-      (if (not (record-internal? obj))
+    (define pred (record-predicate rtd))
+    
+    (let* ((parent (record-type-parent rtd))
+           (parent-nfields (if parent
+                               (length (record-type-fields parent))
+                               0))
+           (k (+ k parent-nfields)))
+      (unless (and (<= parent-nfields k)
+                   (< k (length (record-type-fields rtd))))
+        (r6rs-raise (make-assertion-violation)))
+      (lambda (obj)
+        (unless (pred obj)
           (r6rs-raise (make-assertion-violation)))
-      (record-accessor-inner obj)))
+        (struct-ref obj k))))
 
   (define (record-mutator rtd k)
-    (define (record-mutator-inner obj val)
-      (and obj (or (and (eq? (struct-vtable obj) rtd)
-                        (struct-set! obj (+ k 1) val))
-                   (record-mutator-inner (struct-ref obj 0) val))))
-    (let ((bit-field (struct-ref rtd rtd-index-field-bit-field)))
-      (if (zero? (logand bit-field (ash 1 k)))
-         (r6rs-raise (make-assertion-violation))))
-    (lambda (obj val) (record-mutator-inner obj val)))
+    (define pred (record-predicate rtd))
+    (let* ((parent (record-type-parent rtd))
+           (parent-nfields (if parent
+                               (length (record-type-fields parent))
+                               0))
+           (k (+ k parent-nfields)))
+      (unless (and (<= parent-nfields k)
+                   (< k (length (record-type-fields rtd))))
+        (r6rs-raise (make-assertion-violation)))
+      (unless (logbit? k (record-type-mutable-fields rtd))
+        (r6rs-raise (make-assertion-violation)))
+      (lambda (obj val)
+        (unless (pred obj)
+          (r6rs-raise (make-assertion-violation)))
+        (struct-set! obj k val))))
 
   ;; Condition types that are used in the current library.  These are defined
   ;; here and not in (rnrs conditions) to avoid a circular dependency.
@@ -288,4 +214,4 @@
     (define (r6rs-raise-continuable-internal continuation)
       (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
     (call/cc r6rs-raise-continuable-internal))
-)
+  )
diff --git a/test-suite/tests/r6rs-records-procedural.test 
b/test-suite/tests/r6rs-records-procedural.test
index a1621f1..81a49fc 100644
--- a/test-suite/tests/r6rs-records-procedural.test
+++ b/test-suite/tests/r6rs-records-procedural.test
@@ -57,7 +57,10 @@
        (lambda (continuation)
         (with-exception-handler
          (lambda (condition) 
-           (set! success (assertion-violation? condition))
+            ;; FIXME: While R6RS specifies an assertion violation, by
+            ;; building on core Guile records we just see a Guile
+            ;; condition, which is just &serious.
+           (set! success (serious-condition? condition))
            (continuation))
          (lambda () (make-record-type-descriptor
                      'sealed-point-subtype :sealed-point #f #f #f
@@ -81,7 +84,11 @@
               (lambda (continuation)
                 (with-exception-handler
                  (lambda (condition)
-                   (if (assertion-violation? condition)
+                    ;; FIXME: While R6RS specifies an assertion
+                    ;; violation, by building on core Guile records we
+                    ;; just see a Guile condition, which is just
+                    ;; &serious.
+                   (if (serious-condition? condition)
                        (set! success (+ success 1)))
                    (continuation))
                  thunk))))))