mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Rebase R6RS records on top of core records

Browse source 
* 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
Download patch file Download diff file Expand all files Collapse all files

6
module/ice-9/boot-9.scm
View file

@ -1229,6 +1229,8 @@ VALUE."
(assq-ref (record-type-properties rtd) 'extensible?)) (assq-ref (record-type-properties rtd) 'extensible?))
(define (record-type-opaque? rtd) (define (record-type-opaque? rtd)
(assq-ref (record-type-properties rtd) 'opaque?)) (assq-ref (record-type-properties rtd) 'opaque?))
(define (record-type-uid rtd)
(assq-ref (record-type-properties rtd) 'uid))
(define (record-type-parents rtd) (define (record-type-parents rtd)
(unless (record-type? rtd) (unless (record-type? rtd)
@ -1384,7 +1386,9 @@ VALUE."
(let ((maybe-acons (lambda (k v tail) (let ((maybe-acons (lambda (k v tail)
(if v (acons k v tail) tail)))) (if v (acons k v tail) tail))))
(maybe-acons 'extensible? extensible? (maybe-acons 'extensible? extensible?
(maybe-acons 'opaque? opaque? '())))) (maybe-acons 'opaque? opaque?
(maybe-acons 'uid uid
'())))))
(cond (cond
((and uid (hashq-ref prefab-record-types uid)) ((and uid (hashq-ref prefab-record-types uid))

27
module/rnrs/conditions.scm
View file

@ -125,13 +125,7 @@
((_ condition-type supertype constructor predicate ((_ condition-type supertype constructor predicate
(field accessor) ...) (field accessor) ...)
(letrec-syntax (letrec-syntax
((transform-fields ((generate-accessors
(syntax-rules ()
((_ (f a) . rest)
(cons '(immutable f a) (transform-fields . rest)))
((_) '())))
(generate-accessors
(syntax-rules () (syntax-rules ()
((_ counter (f a) . rest) ((_ counter (f a) . rest)
(begin (define a (begin (define a
@ -140,16 +134,15 @@
(record-accessor condition-type counter))) (record-accessor condition-type counter)))
(generate-accessors (+ counter 1) . rest))) (generate-accessors (+ counter 1) . rest)))
((_ counter) (begin))))) ((_ counter) (begin)))))
(begin (define condition-type
(define condition-type (make-record-type-descriptor
(make-record-type-descriptor 'condition-type supertype #f #f #f
'condition-type supertype #f #f #f '#((immutable field) ...)))
(list->vector (transform-fields (field accessor) ...)))) (define constructor
(define constructor (record-constructor
(record-constructor (make-record-constructor-descriptor condition-type #f #f)))
(make-record-constructor-descriptor condition-type #f #f))) (define predicate (condition-predicate condition-type))
(define predicate (condition-predicate condition-type)) (generate-accessors 0 (field accessor) ...)))))
(generate-accessors 0 (field accessor) ...))))))
(define &condition (@@ (rnrs records procedural) &condition)) (define &condition (@@ (rnrs records procedural) &condition))
(define &condition-constructor-descriptor (define &condition-constructor-descriptor

74
module/rnrs/records/inspection.scm
View file

@ -1,6 +1,6 @@
;;; inspection.scm --- Inspection support for R6RS records ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -31,51 +31,47 @@
(import (rnrs arithmetic bitwise (6)) (import (rnrs arithmetic bitwise (6))
(rnrs base (6)) (rnrs base (6))
(rnrs records procedural (6)) (rnrs records procedural (6))
(only (guile) struct-ref struct-vtable vtable-index-layout @@)) (rename (only (guile)
unless
(define record-internal? (@@ (rnrs records procedural) record-internal?)) logbit?
record?
(define rtd-index-name (@@ (rnrs records procedural) rtd-index-name)) record-type-name
(define rtd-index-parent (@@ (rnrs records procedural) rtd-index-parent)) record-type-parent
(define rtd-index-uid (@@ (rnrs records procedural) rtd-index-uid)) record-type-fields
(define rtd-index-sealed? (@@ (rnrs records procedural) rtd-index-sealed?)) record-type-opaque?
(define rtd-index-opaque? (@@ (rnrs records procedural) rtd-index-opaque?)) record-type-extensible?
(define rtd-index-field-names record-type-uid
(@@ (rnrs records procedural) rtd-index-field-names)) record-type-mutable-fields
(define rtd-index-field-bit-field struct-vtable)
(@@ (rnrs records procedural) rtd-index-field-bit-field)) (record? guile:record?)))
(define (record? obj) (define (record? obj)
(and (record-internal? obj) (and (guile:record? obj)
(not (record-type-opaque? (struct-vtable obj))))) (not (record-type-opaque? (struct-vtable obj)))))
(define (record-rtd record) (define (record-rtd record)
(or (and (record-internal? record) (unless (record? record)
(let ((rtd (struct-vtable record))) (assertion-violation 'record-rtd "not a record" record))
(and (not (struct-ref rtd rtd-index-opaque?)) rtd))) (struct-vtable record))
(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)))
(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) (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) (define (record-type-sealed? rtd)
(struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?)) (not (record-type-extensible? rtd)))
(define (record-type-opaque? rtd)
(struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
(define (record-type-field-names 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) (define (record-field-mutable? rtd k)
(bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd) (let* ((parent (record-type-parent rtd))
rtd-index-field-bit-field) (parent-nfields (if parent
k)) (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)))))

316
module/rnrs/records/procedural.scm
View file

@ -19,7 +19,7 @@
(library (rnrs records procedural (6)) (library (rnrs records procedural (6))
(export make-record-type-descriptor (export make-record-type-descriptor
record-type-descriptor? (rename (record-type? record-type-descriptor?))
make-record-constructor-descriptor make-record-constructor-descriptor
record-constructor record-constructor
@ -28,214 +28,140 @@
record-mutator) record-mutator)
(import (rnrs base (6)) (import (rnrs base (6))
(only (guile) cons* (only (rename (guile)
logand (record-accessor guile:record-accessor))
logior cons*
ash logbit?
and=> when unless
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
make-hash-table throw
hashq-ref
hashq-set!
vector->list struct-ref
struct-set!
vtable-offset-user) make-record-type
(ice-9 receive) record-type?
(only (srfi :1) fold split-at take)) 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) vector->list))
(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))
(define (make-record-type-descriptor name parent uid sealed? opaque? fields) (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
(define fields-pair (make-record-type name (vector->list fields) #:parent parent #:uid uid
(let loop ((field-list (vector->list fields)) #:extensible? (not sealed?)
(layout-sym 'pw) #:opaque? (or opaque?
(layout-bit-field 0) (and parent (record-type-opaque? parent)))))
(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 record-constructor-descriptor
(define fields-bit-field (cdr fields-pair)) (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 (make-record-constructor-descriptor rtd parent-rcd protocol)
(define late-rtd #f) (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) (define (record-constructor rcd)
(and (record-internal? obj) ;; The protocol facility allows users to define constructors whose
(or (eq? (struct-vtable obj) late-rtd) ;; arguments don't directly correspond to the fields of the record
(and=> (struct-ref obj 0) private-record-predicate)))) ;; type; instead, the protocol managed a mapping from "args" to
;; "inits", where args are constructor args, and inits are the
(define (field-binder parent-struct . args) ;; resulting set of initial field values.
(apply make-struct/no-tail late-rtd parent-struct args)) (define-syntax if*
(syntax-rules (=>)
(if (and parent (struct-ref parent rtd-index-sealed?)) ((if* (exp => id) consequent alternate)
(r6rs-raise (make-assertion-violation))) (cond (exp => (lambda (id) consequent)) (else alternate)))))
(define raw-constructor
(let ((matching-rtd (and uid (hashq-ref uid-table uid))) (record-type-constructor (rcd-rtd rcd)))
(opaque? (or opaque? (and parent (struct-ref (if* ((rcd-protocol rcd) => protocol)
parent rtd-index-opaque?))))) (protocol
(if matching-rtd (if* ((rcd-parent rcd) => parent)
(if (equal? (list name (lambda parent-args
parent (lambda inits
sealed? (let collect-inits ((parent parent)
opaque? (parent-args parent-args)
field-names (inits inits))
fields-bit-field) (apply
(list (struct-ref matching-rtd rtd-index-name) (if* ((and parent (rcd-protocol parent)) => protocol)
(struct-ref matching-rtd rtd-index-parent) (protocol
(struct-ref matching-rtd rtd-index-sealed?) (if* ((rcd-parent parent) => parent)
(struct-ref matching-rtd rtd-index-opaque?) ;; Parent has a protocol too; collect
(struct-ref matching-rtd rtd-index-field-names) ;; inits from parent.
(struct-ref matching-rtd (lambda parent-args
rtd-index-field-bit-field))) (lambda parent-inits
matching-rtd (collect-inits parent parent-args
(r6rs-raise (make-assertion-violation))) (append parent-inits
inits))))
(let ((rtd (make-struct/no-tail ;; Default case: parent args correspond
record-type-vtable ;; to inits.
(lambda parent-args
fields-layout (apply raw-constructor
(lambda (obj port) (append parent-args inits)))))
(simple-format ;; Default case: parent args correspond to inits.
port "#<r6rs:record:~A>" name)) (lambda parent-args
(apply raw-constructor
name (append parent-args inits))))
uid parent-args))))
parent raw-constructor))
sealed? raw-constructor))
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-predicate rtd) (struct-ref rtd rtd-index-predicate))
(define (record-accessor rtd k) (define (record-accessor rtd k)
(define (record-accessor-inner obj) (define pred (record-predicate rtd))
(if (eq? (struct-vtable obj) rtd)
(struct-ref obj (+ k 1)) (let* ((parent (record-type-parent rtd))
(and=> (struct-ref obj 0) record-accessor-inner))) (parent-nfields (if parent
(lambda (obj) (length (record-type-fields parent))
(if (not (record-internal? obj)) 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))) (r6rs-raise (make-assertion-violation)))
(record-accessor-inner obj))) (struct-ref obj k))))
(define (record-mutator rtd k) (define (record-mutator rtd k)
(define (record-mutator-inner obj val) (define pred (record-predicate rtd))
(and obj (or (and (eq? (struct-vtable obj) rtd) (let* ((parent (record-type-parent rtd))
(struct-set! obj (+ k 1) val)) (parent-nfields (if parent
(record-mutator-inner (struct-ref obj 0) val)))) (length (record-type-fields parent))
(let ((bit-field (struct-ref rtd rtd-index-field-bit-field))) 0))
(if (zero? (logand bit-field (ash 1 k))) (k (+ k parent-nfields)))
(r6rs-raise (make-assertion-violation)))) (unless (and (<= parent-nfields k)
(lambda (obj val) (record-mutator-inner obj val))) (< 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 ;; Condition types that are used in the current library. These are defined
;; here and not in (rnrs conditions) to avoid a circular dependency. ;; here and not in (rnrs conditions) to avoid a circular dependency.
@ -288,4 +214,4 @@
(define (r6rs-raise-continuable-internal continuation) (define (r6rs-raise-continuable-internal continuation)
(throw 'r6rs:exception (make-raise-object-wrapper obj continuation))) (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
(call/cc r6rs-raise-continuable-internal)) (call/cc r6rs-raise-continuable-internal))
) )

11
test-suite/tests/r6rs-records-procedural.test
View file

@ -57,7 +57,10 @@
(lambda (continuation) (lambda (continuation)
(with-exception-handler (with-exception-handler
(lambda (condition) (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)) (continuation))
(lambda () (make-record-type-descriptor (lambda () (make-record-type-descriptor
'sealed-point-subtype :sealed-point #f #f #f 'sealed-point-subtype :sealed-point #f #f #f
@ -81,7 +84,11 @@
(lambda (continuation) (lambda (continuation)
(with-exception-handler (with-exception-handler
(lambda (condition) (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))) (set! success (+ success 1)))
(continuation)) (continuation))
thunk)))))) thunk))))))