commit 79f906037cede5bbc2b1d4adf27559663e890241
parent eae6a71f765f4c9a7044e6440d973522f6a99543
Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
Date: Thu, 3 Sep 2015 14:00:46 +0200
Support record inspection.
Diffstat:
5 files changed, 116 insertions(+), 46 deletions(-)
diff --git a/srfi-123.html b/srfi-123.html
@@ -125,6 +125,7 @@ vec ;=> #(3 1 2)</code></pre>
<p>The intent of this SRFI is to encourage Scheme systems to extend their standard library in accordance with the above specification. On the meanwhile, the sample implementation can be used as a separate library, but certain considerations apply.</p>
<p>The <code>define-record-type</code> export of the library conflicts with the one in <code>(scheme base)</code>, so either has to be renamed, or more typically, the one from <code>(scheme base)</code> excluded.</p>
<p>Record types not defined with the <code>define-record-type</code> exported by this library won't work with <code>ref</code>, <code>ref*</code>, or their setters.</p>
+<p>This problem does not apply to implementations supporting inspection of records and record types.</p>
<h2 id="implementation">Implementation</h2>
<p>A sample implementation as a library is found in the version control repository of this SRFI.</p>
<p>It might be desirable for Scheme systems to offer a more efficient <code>type-of</code> procedure than the one used in this implementation, which in the worst case consumes linear time with regard to the number of types (including every record type) within the system, albeit with a very small constant factor: one call to each type predicate.</p>
diff --git a/srfi-123.md b/srfi-123.md
@@ -291,6 +291,9 @@ the one from `(scheme base)` excluded.
Record types not defined with the `define-record-type` exported by
this library won't work with `ref`, `ref*`, or their setters.
+This problem does not apply to implementations supporting inspection
+of records and record types.
+
Implementation
--------------
diff --git a/srfi/123.body.scm b/srfi/123.body.scm
@@ -53,6 +53,36 @@
(else
(list-set! pair key value))))
+;;; Record inspection support
+
+(cond-expand
+ ((or (library (srfi 99))
+ (library (rnrs records inspection))
+ (library (r6rs records inspection)))
+ (cond-expand
+ ((not (library (srfi 99)))
+ (define rtd-accessor record-accessor)
+ (define rtd-mutator record-mutator))
+ (else))
+ (define (record-ref record field)
+ (let* ((rtd (record-rtd record))
+ (accessor (rtd-accessor rtd field)))
+ (accessor record)))
+ (define (record-set! record field value)
+ (let* ((rtd (record-rtd record))
+ (mutator (rtd-mutator rtd field)))
+ (mutator record value)))
+ (define record-getters
+ (list (cons record? record-ref)))
+ (define record-setters
+ (list (cons record? record-set!)))
+ (define record-types
+ (list record?)))
+ (else
+ (define record-getters '())
+ (define record-setters '())
+ (define record-types '())))
+
;;; SRFI-4 support
;;; In some implementations, SRFI-4 vectors are also bytevectors. We accomodate
@@ -167,6 +197,7 @@
(cons pair? pair-ref)
(cons string? string-ref)
(cons vector? vector-ref))
+ record-getters
srfi-4-getters)))
(define setter-table
@@ -177,6 +208,7 @@
(cons pair? pair-set!)
(cons string? string-set!)
(cons vector? vector-set!))
+ record-setters
srfi-4-setters)))
(define sparse-types
@@ -186,6 +218,7 @@
(append
(list boolean? bytevector? char? eof-object? hashtable? null? number? pair?
port? procedure? string? symbol? vector?)
+ record-types
srfi-4-types))
(define (register-getter-with-setter! type getter sparse?)
@@ -195,48 +228,53 @@
(when sparse?
(push! sparse-types type)))
-(define-syntax define-record-type
- (syntax-rules ()
- ((_ <name> <constructor> <pred> <field> ...)
- (begin
- (%define-record-type <name> <constructor> <pred> <field> ...)
- ;; Throw-away definition to not disturb an internal definitions sequence.
- (define __throwaway
- (begin
- (register-getter-with-setter!
- <pred>
- (getter-with-setter (record-getter <field> ...)
- (record-setter <field> ...))
- #f)
- ;; Return the implementation's preferred "unspecified" value.
- (if #f #f)))))))
-
-(define-syntax record-getter
- (syntax-rules ()
- ((_ (<field> <getter> . <rest>) ...)
- (let ((getters (alist->hashtable (list (cons '<field> <getter>) ...))))
- (lambda (record field)
- (let ((getter (or (ref getters field #f)
- (error "No such field of record." record field))))
- (getter record)))))))
-
-(define-syntax record-setter
- (syntax-rules ()
- ((_ . <rest>)
- (%record-setter () . <rest>))))
-
-(define-syntax %record-setter
- (syntax-rules ()
- ((_ <setters> (<field> <getter>) . <rest>)
- (%record-setter <setters> . <rest>))
- ((_ <setters> (<field> <getter> <setter>) . <rest>)
- (%record-setter ((<field> <setter>) . <setters>) . <rest>))
- ((_ ((<field> <setter>) ...))
- (let ((setters (alist->hashtable (list (cons '<field> <setter>) ...))))
- (lambda (record field value)
- (let ((setter (or (ref setters field #f)
- (error "No such assignable field of record."
- record field))))
- (setter record value)))))))
+(cond-expand
+ ((not (or (library (srfi 99))
+ (library (rnrs records inspection))
+ (library (r6rs records inspection))))
+ (define-syntax define-record-type
+ (syntax-rules ()
+ ((_ <name> <constructor> <pred> <field> ...)
+ (begin
+ (%define-record-type <name> <constructor> <pred> <field> ...)
+ ;; Throw-away definition to not disturb an internal definitions
+ ;; sequence.
+ (define __throwaway
+ (begin
+ (register-getter-with-setter!
+ <pred>
+ (getter-with-setter (record-getter <field> ...)
+ (record-setter <field> ...))
+ #f)
+ ;; Return the implementation's preferred "unspecified" value.
+ (if #f #f)))))))
+
+ (define-syntax record-getter
+ (syntax-rules ()
+ ((_ (<field> <getter> . <rest>) ...)
+ (let ((getters (alist->hashtable (list (cons '<field> <getter>) ...))))
+ (lambda (record field)
+ (let ((getter (or (ref getters field #f)
+ (error "No such field of record." record field))))
+ (getter record)))))))
+
+ (define-syntax record-setter
+ (syntax-rules ()
+ ((_ . <rest>)
+ (%record-setter () . <rest>))))
+
+ (define-syntax %record-setter
+ (syntax-rules ()
+ ((_ <setters> (<field> <getter>) . <rest>)
+ (%record-setter <setters> . <rest>))
+ ((_ <setters> (<field> <getter> <setter>) . <rest>)
+ (%record-setter ((<field> <setter>) . <setters>) . <rest>))
+ ((_ ((<field> <setter>) ...))
+ (let ((setters (alist->hashtable (list (cons '<field> <setter>) ...))))
+ (lambda (record field value)
+ (let ((setter (or (ref setters field #f)
+ (error "No such assignable field of record."
+ record field))))
+ (setter record value)))))))))
;;; generic-ref-set.body.scm ends here
diff --git a/srfi/123.sld b/srfi/123.sld
@@ -2,17 +2,33 @@
(export
ref ref* ~ register-getter-with-setter!
$bracket-apply$
- define-record-type
set! setter getter-with-setter)
(import
- (rename (except (scheme base) set!)
- (define-record-type %define-record-type))
+ (except (scheme base) set! define-record-type)
(scheme case-lambda)
(r6rs hashtables)
(srfi 1)
(srfi 17)
(srfi 31))
(cond-expand
+ ;; Favor SRFI-99.
+ ((library (srfi 99))
+ (import (srfi 99)))
+ ;; We assume that if there's the inspection library, there's also the
+ ;; syntactic and procedural libraries.
+ ((library (rnrs records inspection))
+ (import (rnrs records syntactic))
+ (import (rnrs records procedural))
+ (import (rnrs records inspection)))
+ ((library (r6rs records inspection))
+ (import (r6rs records syntactic))
+ (import (r6rs records procedural))
+ (import (r6rs records inspection)))
+ (else
+ (import (rename (only (scheme base) define-record-type)
+ (define-record-type %define-record-type)))
+ (export define-record-type)))
+ (cond-expand
((library (srfi 4))
(import (srfi 4)))
(else))
diff --git a/tests/srfi-123.sld b/tests/srfi-123.sld
@@ -28,6 +28,18 @@
(srfi 64)
(srfi 123))
(cond-expand
+ ((library (srfi 99))
+ (import (srfi 99)))
+ ((library (rnrs records inspection))
+ (import (rnrs records syntactic))
+ (import (rnrs records procedural)))
+ (import (rnrs records inspection))
+ ((library (r6rs records inspection))
+ (import (r6rs records syntactic))
+ (import (r6rs records procedural)))
+ (import (r6rs records inspection))
+ (else))
+ (cond-expand
((library (srfi 4))
(import (srfi 4)))
(else))
