mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
5870188eb4
* libguile/struct.h (SCM_VTABLE_BASE_LAYOUT): Layout is a "pr" field. * module/ice-9/boot-9.scm (record-type-vtable): Record vtable fields are writable. (<parameter>): "pw" fields. * module/oop/goops.scm (<class>, %compute-layout): <read-only> fields are "pw" underneath. * module/rnrs/records/procedural.scm (record-type-vtable) (record-constructor-vtable, make-record-type-descriptor): Use "pw" fields in vtables. * module/srfi/srfi-35.scm (%condition-type-vtable) (struct-layout-for-condition): "pw" fields in vtables. * test-suite/tests/goops.test: * test-suite/tests/structs.test: Use "pw" fields only. * benchmark-suite/benchmarks/structs.bm: Update for make-struct/no-tail, to use pw fields, and also to remove useless tests that the compiler would optimize away. * doc/ref/api-data.texi (Vtables): Add a note about the now-vestigial permissions character and update documentation. (Structure Basics, Meta-Vtables): Update examples. * libguile/hash.c (scm_i_struct_hash): Remove code that would handle opaque/self fields. * libguile/print.h (SCM_PRINT_STATE_LAYOUT): Use "pw" fields. * libguile/struct.c (scm_struct_init): Simplify check for hidden fields. * libguile/values.c (scm_init_values): Field is "pw".
291 lines
10 KiB
Scheme
291 lines
10 KiB
Scheme
;;; procedural.scm --- Procedural interface to R6RS records
|
||
|
||
;; Copyright (C) 2010, 2017 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
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library 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
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(library (rnrs records procedural (6))
|
||
(export make-record-type-descriptor
|
||
record-type-descriptor?
|
||
make-record-constructor-descriptor
|
||
|
||
record-constructor
|
||
record-predicate
|
||
record-accessor
|
||
record-mutator)
|
||
|
||
(import (rnrs base (6))
|
||
(only (guile) cons*
|
||
logand
|
||
logior
|
||
ash
|
||
|
||
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
|
||
|
||
make-hash-table
|
||
hashq-ref
|
||
hashq-set!
|
||
|
||
vector->list
|
||
|
||
vtable-offset-user)
|
||
(ice-9 receive)
|
||
(only (srfi :1) fold split-at take))
|
||
|
||
(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))
|
||
|
||
(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)))))))
|
||
|
||
(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))
|
||
(r6rs-raise (make-assertion-violation)))
|
||
(record-accessor-inner obj)))
|
||
|
||
(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)))
|
||
|
||
;; Condition types that are used in the current library. These are defined
|
||
;; here and not in (rnrs conditions) to avoid a circular dependency.
|
||
|
||
(define &condition (make-record-type-descriptor '&condition #f #f #f #f '#()))
|
||
(define &condition-constructor-descriptor
|
||
(make-record-constructor-descriptor &condition #f #f))
|
||
|
||
(define &serious (make-record-type-descriptor
|
||
'&serious &condition #f #f #f '#()))
|
||
(define &serious-constructor-descriptor
|
||
(make-record-constructor-descriptor
|
||
&serious &condition-constructor-descriptor #f))
|
||
|
||
(define make-serious-condition
|
||
(record-constructor &serious-constructor-descriptor))
|
||
|
||
(define &violation (make-record-type-descriptor
|
||
'&violation &serious #f #f #f '#()))
|
||
(define &violation-constructor-descriptor
|
||
(make-record-constructor-descriptor
|
||
&violation &serious-constructor-descriptor #f))
|
||
(define make-violation (record-constructor &violation-constructor-descriptor))
|
||
|
||
(define &assertion (make-record-type-descriptor
|
||
'&assertion &violation #f #f #f '#()))
|
||
(define make-assertion-violation
|
||
(record-constructor
|
||
(make-record-constructor-descriptor
|
||
&assertion &violation-constructor-descriptor #f)))
|
||
|
||
;; Exception wrapper type, along with a wrapping `throw' implementation.
|
||
;; These are used in the current library, and so they are defined here and not
|
||
;; in (rnrs exceptions) to avoid a circular dependency.
|
||
|
||
(define &raise-object-wrapper
|
||
(make-record-type-descriptor '&raise-object-wrapper #f #f #f #f
|
||
'#((immutable obj) (immutable continuation))))
|
||
(define make-raise-object-wrapper
|
||
(record-constructor (make-record-constructor-descriptor
|
||
&raise-object-wrapper #f #f)))
|
||
(define raise-object-wrapper? (record-predicate &raise-object-wrapper))
|
||
(define raise-object-wrapper-obj (record-accessor &raise-object-wrapper 0))
|
||
(define raise-object-wrapper-continuation
|
||
(record-accessor &raise-object-wrapper 1))
|
||
|
||
(define (r6rs-raise obj)
|
||
(throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
|
||
(define (r6rs-raise-continuable obj)
|
||
(define (r6rs-raise-continuable-internal continuation)
|
||
(throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
|
||
(call/cc r6rs-raise-continuable-internal))
|
||
)
|