summaryrefslogtreecommitdiff
path: root/module/rnrs/records/procedural.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs/records/procedural.scm')
-rw-r--r--module/rnrs/records/procedural.scm291
1 files changed, 291 insertions, 0 deletions
diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm
new file mode 100644
index 000000000..cbcd4e5ce
--- /dev/null
+++ b/module/rnrs/records/procedural.scm
@@ -0,0 +1,291 @@
+;;; 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))
+)