1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00

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.
This commit is contained in:
Andy Wingo 2019-10-29 11:30:41 +01:00
parent 1ae0f8d490
commit 73d0a3bccb
5 changed files with 180 additions and 254 deletions

View file

@ -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))

View file

@ -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

View file

@ -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)))
(unless (record? record)
(assertion-violation 'record-rtd "not a record" record))
(struct-vtable record))
(define (guarantee-rtd who rtd)
(if (record-type-descriptor? rtd)
rtd
(assertion-violation who "not a record type descriptor" rtd)))
(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)))))

View file

@ -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)))))))
(make-record-type name (vector->list fields) #:parent parent #:uid uid
#:extensible? (not sealed?)
#:opaque? (or opaque?
(and parent (record-type-opaque? parent)))))
(define fields-layout (car fields-pair))
(define fields-bit-field (cdr fields-pair))
(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 field-names (list->vector (map cadr (vector->list fields))))
(define late-rtd #f)
(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 (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)))))))
(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))
)
)

View file

@ -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))))))