Here's a patch for adding SRFI-123 support. It applies on stable-2.0.
Please tell me if the changes to (srfi srfi-9) and (rnrs bytevectors)
are OK. The test suite passes. I also added a rudimentary test-suite
for SRFI-123.
I kept the documentation brief, since the full documentation can be
found in the SRFI document itself.
To clarify: this SRFI caters to programmers writing code that is 1) not
performance-critical, 2) rich in calls to verbose procedures like
hashtable-ref which become annoying. "Scripty" code if you will. It's
also a matter of taste. It doesn't have much foot-shooting potential so
having it shouldn't hurt. (Making this disclaimer because some Guilers
didn't seem to like it.)
Thanks in advance for the review. :-)
Taylan
>From 3f3a1225d76340d283c53830f990b18a485d3416 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayi...@gmail.com>
Date: Sun, 23 Aug 2015 15:21:49 +0200
Subject: [PATCH] Add SRFI-123 support.
* module/srfi/srfi-123.scm: New file.
* module/Makefile.am (SRFI_SOURCES): Add it.
* doc/ref/srfi-modules.texi (SRFI Support): Document it.
* module/rnrs/hashtables.scm: Register hashtable-ref and hashtable-set!
with SRFI-123.
* module/srfi/srfi-9.scm (%define-record-type): Register an SRFI-123
getter/setter for the defined record type.
* test-suite/tests/srfi-123.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add it.
---
doc/ref/srfi-modules.texi | 54 ++++++++++++
module/Makefile.am | 3 +-
module/rnrs/hashtables.scm | 12 ++-
module/srfi/srfi-123.scm | 183 +++++++++++++++++++++++++++++++++++++++++
module/srfi/srfi-9.scm | 42 +++++++++-
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-123.test | 79 ++++++++++++++++++
7 files changed, 370 insertions(+), 4 deletions(-)
create mode 100644 module/srfi/srfi-123.scm
create mode 100644 test-suite/tests/srfi-123.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index d8ed8e1..9963526 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -63,6 +63,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
* SRFI-111:: Boxes.
+* SRFI-123:: Generic accessor and modifier operators.
@end menu
@@ -5603,6 +5604,59 @@ Return the current contents of @var{box}.
Set the contents of @var{box} to @var{value}.
@end deffn
+@node SRFI-123
+@subsection SRFI-123 Generic accessor and modifier operators.
+@cindex SRFI-123
+
+@uref{http://srfi.schemers.org/srfi-123/srfi-123.html, SRFI-123}
+provides a generic @var{ref} procedure that works on a variety of
+compound data types through dynamic dispatch, and a related
+@uref{http://srfi.schemers.org/srfi-17/srfi-17.html, SRFI-17} setter for
+it. It also provides @var{ref*} which can walk through nested data
+structures via a given sequence of indices/keys, and again a related
+SRFI-17 setter. There is a synonym to @var{ref*}, called @var{~}. New
+types can be registered via @var{register-getter-with-setter!}, but this
+is generally unnecessary because record types are registered
+automatically.
+
+@deffn {Scheme Procedure} ref object field [default]
+Returns the value for @var{field} in @var{object}, e.g. the value for a
+given index in a list or vector, the value associated with a given key
+in a hashtable, etc. The @var{default} argument is accepted for
+hashtables and returned when the hashtable look-up fails; an exception
+is raised if it isn't provided in that case.
+
+If @var{object} is a record, @var{field} may be a symbol denoting a
+field of the relevant record type.
+
+Guile's native hashtables aren't supported because there is no single
+referencing or setting procedure for them. Alists also aren't
+supported, because they can't be easily distinguished from lists.
+
+There is an SRFI-17 setter for this procedure, which does the expected
+thing.
+@end deffn
+
+@deffn {Scheme Procedure} ref* object field1 field2 @dots{}
+@deffnx {Scheme Procedure} ~ object field1 field2 @dots{}
+Calls @var{ref} on @var{object} with @var{field1}, then with
+@var{field2} on the result, and so on, and returns the ultimate result.
+(The @var{ref} calls are all done without the @var{default} argument.)
+
+This procedure also has an SRFI-17 setter.
+@end deffn
+
+@deffn {Scheme Procedure} register-getter-with-setter! type getter sparse?
+Registers a new type for the dynamic dispatch. The type predicate
+@var{type} should be for a disjoint type; it should not overlap with any
+other types as for instance @var{pair?} and @var{list?} do. If you want
+to dispatch to different actions on a single type, register a
+getter/setter which does this sub-dispatch itself.
+
+The Boolean @var{sparse?} indicates whether the type is a ``sparse'' one
+like hashtables are.
+@end deffn
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/module/Makefile.am b/module/Makefile.am
index 7e96de7..13e5000 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -295,7 +295,8 @@ SRFI_SOURCES = \
srfi/srfi-69.scm \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
- srfi/srfi-111.scm
+ srfi/srfi-111.scm \
+ srfi/srfi-123.scm
RNRS_SOURCES = \
rnrs/base.scm \
diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
index 98d2d76..871f841 100644
--- a/module/rnrs/hashtables.scm
+++ b/module/rnrs/hashtables.scm
@@ -68,7 +68,9 @@
(hash equal-hash)
(hash-by-identity symbol-hash))
(rnrs base (6))
- (rnrs records procedural (6)))
+ (rnrs records procedural (6))
+ (srfi :17)
+ (srfi :123))
(define r6rs:hashtable
(make-record-type-descriptor
@@ -178,4 +180,10 @@
(hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
(define (hashtable-hash-function hashtable)
- (r6rs:hashtable-orig-hash-function hashtable)))
+ (r6rs:hashtable-orig-hash-function hashtable))
+
+ (register-getter-with-setter!
+ hashtable?
+ (getter-with-setter hashtable-ref
+ hashtable-set!)
+ #t))
diff --git a/module/srfi/srfi-123.scm b/module/srfi/srfi-123.scm
new file mode 100644
index 0000000..41c377d
--- /dev/null
+++ b/module/srfi/srfi-123.scm
@@ -0,0 +1,183 @@
+;;; srfi-123.scm -- Generic accessor and modifier operators
+
+;; Copyright (C) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayi...@gmail.com>
+;;
+;; 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
+
+;;; To solve a circular import problem with SRFI-9, we don't import
+;;; (rnrs hashtables) here; instead (rnrs hashtables) hooks itself into
+;;; this SRFI via register-getter-with-setter!.
+
+(define-module (srfi srfi-123)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-17)
+ #:use-module (srfi srfi-31)
+ #:use-module (ice-9 hash-table)
+ #:use-module (rnrs bytevectors)
+ #:export (ref ref* ~ register-getter-with-setter! $bracket-apply$))
+
+(cond-expand-provide (current-module) '(srfi-123))
+
+;;; Helpers
+
+(define-syntax push!
+ (syntax-rules ()
+ ((_ <list-var> <x>)
+ (set! <list-var> (cons <x> <list-var>)))))
+
+(define (pair-ref pair key)
+ (cond
+ ((eqv? 'car key)
+ (car pair))
+ ((eqv? 'cdr key)
+ (cdr pair))
+ (else
+ (list-ref pair key))))
+
+(define (pair-set! pair key value)
+ (cond
+ ((eqv? 'car key)
+ (set-car! pair value))
+ ((eqv? 'cdr key)
+ (set-cdr! pair value))
+ (else
+ (list-set! pair key value))))
+
+;;; SRFI-4 support
+
+(define srfi-4-types
+ (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector?
+ s64vector? u64vector?))
+
+(define bytevector-ref
+ (let ((getters (alist->hashq-table
+ (list (cons s8vector? s8vector-ref)
+ (cons u8vector? u8vector-ref)
+ (cons s16vector? s16vector-ref)
+ (cons u16vector? u16vector-ref)
+ (cons s32vector? s32vector-ref)
+ (cons u32vector? u32vector-ref)
+ (cons s64vector? s64vector-ref)
+ (cons u64vector? u64vector-ref)))))
+ (lambda (bytevector index)
+ (let ((type (find (lambda (pred) (pred bytevector)) srfi-4-types)))
+ (if type
+ ((hashq-ref getters type) bytevector index)
+ (error "Wrong type argument." bytevector))))))
+
+(define bytevector-set!
+ (let ((setters (alist->hashq-table
+ (list (cons s8vector? s8vector-set!)
+ (cons u8vector? u8vector-set!)
+ (cons s16vector? s16vector-set!)
+ (cons u16vector? u16vector-set!)
+ (cons s32vector? s32vector-set!)
+ (cons u32vector? u32vector-set!)
+ (cons s64vector? s64vector-set!)
+ (cons u64vector? u64vector-set!)))))
+ (lambda (bytevector index value)
+ (let ((type (find (lambda (pred) (pred bytevector)) srfi-4-types)))
+ (if type
+ ((hashq-ref setters type) bytevector index value)
+ (error "Wrong type argument." bytevector))))))
+
+;;; Main
+
+(define %ref
+ (case-lambda
+ ((object field)
+ (let ((getter (lookup-getter object))
+ (sparse? (sparse-type? object)))
+ (if sparse?
+ (let* ((not-found (cons #f #f))
+ (result (getter object field not-found)))
+ (if (eqv? result not-found)
+ (error "Object has no entry for field." object field)
+ result))
+ (getter object field))))
+ ((object field default)
+ (let ((getter (lookup-getter object)))
+ (getter object field default)))))
+
+(define (%ref* object field . fields)
+ (if (null? fields)
+ (%ref object field)
+ (apply %ref* (%ref object field) fields)))
+
+(define (%set! object field value)
+ (let ((setter (lookup-setter object)))
+ (setter object field value)))
+
+(define ref
+ (getter-with-setter
+ %ref
+ (lambda (object field value)
+ (%set! object field value))))
+
+(define ref*
+ (getter-with-setter
+ %ref*
+ (rec (set!* object field rest0 . rest)
+ (if (null? rest)
+ (%set! object field rest0)
+ (apply set!* (ref object field) rest0 rest)))))
+
+(define ~ ref*)
+
+(define $bracket-apply$ ref*)
+
+(define (lookup-getter object)
+ (or (hashq-ref getter-table (type-of object) #f)
+ (error "No generic getter for object's type." object)))
+
+(define (lookup-setter object)
+ (or (hashq-ref setter-table (type-of object) #f)
+ (error "No generic setter for object's type." object)))
+
+(define (sparse-type? object)
+ (memv (type-of object) sparse-types))
+
+(define (type-of object)
+ (find (lambda (pred) (pred object)) type-list))
+
+(define getter-table
+ (alist->hashq-table
+ (list (cons bytevector? bytevector-ref)
+ (cons pair? pair-ref)
+ (cons string? string-ref)
+ (cons vector? vector-ref))))
+
+(define setter-table
+ (alist->hashq-table
+ (list (cons bytevector? bytevector-set!)
+ (cons pair? pair-set!)
+ (cons string? string-set!)
+ (cons vector? vector-set!))))
+
+(define sparse-types '())
+
+(define type-list
+ (list boolean? bytevector? char? eof-object? null? number? pair?
+ port? procedure? string? symbol? vector?))
+
+(define (register-getter-with-setter! type getter sparse?)
+ (push! type-list type)
+ (hashq-set! getter-table type getter)
+ (hashq-set! setter-table type (setter getter))
+ (when sparse?
+ (push! sparse-types type)))
+
+;;; srfi-123.scm ends here
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 324fe9c..eeebd25 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -61,6 +61,9 @@
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-17)
+ #:use-module (srfi srfi-123)
+ #:use-module (ice-9 hash-table)
#:use-module (system base ck)
#:export (define-record-type))
@@ -273,6 +276,35 @@
(let ((desc (if immutable? "pr" "pw")))
(string-concatenate (make-list count desc))))
+ (define (generic-getter field-specs)
+ (syntax-case field-specs ()
+ (((name getter-name . rest) ...)
+ #`(let ((getters (alist->hashq-table
+ (list (cons 'name getter-name)
+ ...))))
+ (lambda (record field-name)
+ (let ((getter (or (hashq-ref getters field-name)
+ (error "No such field of record."
+ record field-name))))
+ (getter record)))))))
+
+ (define (generic-setter field-specs)
+ (let ((specs-with-setter (filter-map (lambda (spec)
+ (syntax-case spec ()
+ ((name getter) #f)
+ ((name getter setter) spec)))
+ field-specs)))
+ (syntax-case specs-with-setter ()
+ (((name getter-name setter-name) ...)
+ #`(let ((setters (alist->hashq-table
+ (list (cons 'name setter-name)
+ ...))))
+ (lambda (record field-name value)
+ (let ((setter (or (hashq-ref setters field-name)
+ (error "No such assignable field of record."
+ record field-name))))
+ (setter record value))))))))
+
(syntax-case x ()
((_ immutable? form type-name constructor-spec predicate-name
field-spec ...)
@@ -329,7 +361,15 @@
#,(copier #'type-name getter-ids copier-id)
#,@(if immutable?
(functional-setters copier-id #'(field-spec ...))
- (setters #'type-name #'(field-spec ...))))))
+ (setters #'type-name #'(field-spec ...)))
+ ;; Throw-away definition so as not to disturb a sequence of
+ ;; internal definitions.
+ (define __throwaway
+ (register-getter-with-setter!
+ predicate-name
+ (getter-with-setter #,(generic-getter #'(field-spec ...))
+ #,(generic-setter #'(field-spec ...)))
+ #f)))))
((_ immutable? form . rest)
(syntax-violation
(syntax-case #'form ()
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3b10353..4726086 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -153,6 +153,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-98.test \
tests/srfi-105.test \
tests/srfi-111.test \
+ tests/srfi-123.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/srfi-123.test b/test-suite/tests/srfi-123.test
new file mode 100644
index 0000000..38cc5e0
--- /dev/null
+++ b/test-suite/tests/srfi-123.test
@@ -0,0 +1,79 @@
+;;;; srfi-123.test --- SRFI-123. -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayi...@gmail.com>
+;;;;
+;;;; 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
+
+(define-module (test-srfi-123)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-123)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs hashtables))
+
+(define-record-type <foo> (make-foo a b) foo?
+ (a foo-a set-foo-a!)
+ (b foo-b))
+
+(with-test-prefix "ref"
+ (pass-if "bytevector" (= 1 (ref #u8(0 1 2) 1)))
+ (pass-if "hashtable" (let ((table (make-eqv-hashtable)))
+ (hashtable-set! table 'foo 0)
+ (= 0 (ref table 'foo))))
+ (pass-if "hashtable default" (let ((table (make-eqv-hashtable)))
+ (= 1 (ref table 0 1))))
+ (pass-if "pair" (= 1 (ref (cons 0 1) 'cdr)))
+ (pass-if "list" (= 1 (ref (list 0 1 2) 1)))
+ (pass-if "string" (char=? #\b (ref "abc" 1)))
+ (pass-if "vector" (= 1 (ref (vector 0 1 2) 1)))
+ (pass-if "record" (= 1 (ref (make-foo 0 1) 'b)))
+ (pass-if "srfi-4" (= 1 (ref (s16vector 0 1 2) 1))))
+
+(with-test-prefix "ref*"
+ (pass-if (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr))))
+
+(with-test-prefix "ref setter"
+ (pass-if "bytevector" (let ((bv #u8(0 1 2)))
+ (set! (ref bv 1) 3)
+ (= 3 (ref bv 1))))
+ (pass-if "hashtable" (let ((ht (make-eqv-hashtable)))
+ (set! (ref ht 'foo) 0)
+ (= 0 (ref ht 'foo))))
+ (pass-if "pair" (let ((p (cons 0 1)))
+ (set! (ref p 'cdr) 2)
+ (= 2 (ref p 'cdr))))
+ (pass-if "list" (let ((l (list 0 1 2)))
+ (set! (ref l 1) 3)
+ (= 3 (ref l 1))))
+ (pass-if "string" (let ((s (string #\a #\b #\c)))
+ (set! (ref s 1) #\d)
+ (char=? #\d (ref s 1))))
+ (pass-if "vector" (let ((v (vector 0 1 2)))
+ (set! (ref v 1) 3)
+ (= 3 (ref v 1))))
+ (pass-if "record" (let ((r (make-foo 0 1)))
+ (set! (ref r 'a) 2)
+ (= 2 (ref r 'a))))
+ (pass-if "bad record assignment"
+ (not (false-if-exception (set! (ref (make-foo 0 1) 'b) 2))))
+ (pass-if "srfi-4" (let ((s16v (s16vector 0 1 2)))
+ (set! (ref s16v 1) 3)
+ (= 3 (ref s16v 1)))))
+
+(with-test-prefix "ref* setter"
+ (pass-if (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_)))
+ (set! (ref* obj 1 1 'cdr) 2)
+ (= 2 (ref* obj 1 1 'cdr)))))
--
2.4.3
