Re: Add SRFI-123 support.

[Taylan Ulrich Bayırlı/Kammer]

Oops, it looks like the test suite doesn't pass anymore after I fixed
the problem where I was mutating a literal bytevector.  It should have
been the other way around! :-)

So a #u8() and #vu8() aren't the same thing after all.

(u8vector? #vu8(0))              => #f
(u8vector? (make-bytevector 1))  => #f

Maybe it's a bug?  Anyway, updated patch that works around the issue
cleanly is attached.  I verified that the test suite passes again.

Taylan

>From 7030862fd6e62ae772c92dc7c66b0f41eef61452 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
 <address@hidden>
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       | 185 +++++++++++++++++++++++++++++++++++++++++
 module/srfi/srfi-9.scm         |  42 +++++++++-
 test-suite/Makefile.am         |   1 +
 test-suite/tests/srfi-123.test |  79 ++++++++++++++++++
 7 files changed, 372 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
 
address@hidden SRFI-123
address@hidden SRFI-123 Generic accessor and modifier operators.
address@hidden SRFI-123
+
address@hidden://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
address@hidden://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.
+
address@hidden {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.
address@hidden deffn
+
address@hidden {Scheme Procedure} ref* object field1 field2 @dots{}
address@hidden {Scheme Procedure} ~ object field1 field2 @dots{}
+Calls @var{ref} on @var{object} with @var{field1}, then with
address@hidden 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.
address@hidden deffn
+
address@hidden {Scheme Procedure} register-getter-with-setter! type getter 
sparse?
+Registers a new type for the dynamic dispatch.  The type predicate
address@hidden 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.
address@hidden 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..5a25e6d
--- /dev/null
+++ b/module/srfi/srfi-123.scm
@@ -0,0 +1,185 @@
+;;; srfi-123.scm -- Generic accessor and modifier operators
+
+;; Copyright (C) 2015 Taylan Ulrich Bayırlı/Kammer <address@hidden>
+;;
+;; 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))
+             (getter (if type
+                         (hashq-ref getters type)
+                         bytevector-u8-ref)))
+        (getter bytevector index)))))
+
+(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))
+             (setter (if type
+                         (hashq-ref setters type)
+                         bytevector-u8-set!)))
+        (setter bytevector index value)))))
+
+;;; 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..a33e234
--- /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 <address@hidden>
+;;;;
+;;;; 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 (make-bytevector 3)))
+                          (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.5.0