commit 793db06893653772267f94b41e910db305b898fd
parent c80b0ff59df1d4326151a07a1351b67ff0201484
Author: Arthur A. Gleckler <arthurgleckler@users.noreply.github.com>
Date: Mon, 24 Aug 2015 10:30:44 -0700
Merge pull request #5 from TaylanUB/master
Incorporate Taylan's changes for sixth draft (code only).
Diffstat:
5 files changed, 128 insertions(+), 2 deletions(-)
diff --git a/README.md b/README.md
@@ -0,0 +1,17 @@
+How to run the test suite
+=========================
+
+- Install Chibi Scheme.
+
+- Clone <https://github.com/larcenists/larceny>.
+
+- Enter the directory of this repository and run:
+
+ ```
+ chibi -A . \
+ -A "$larceny_sources"/tools/R6RS \
+ run-tests.scm
+ ```
+
+and it will print the results as well as indicate via process exit
+status whether the suite passed.
diff --git a/run-tests.scm b/run-tests.scm
@@ -0,0 +1,7 @@
+(import (scheme base)
+ (scheme eval)
+ (scheme process-context))
+
+(if (eval '(run-tests) (environment '(tests srfi-123)))
+ (exit 0)
+ (exit 1))
diff --git a/srfi-123.html b/srfi-123.html
@@ -33,7 +33,7 @@ class="antispam">nospam</span>srfi.schemers.org</a></code>. To subscribe to the
<p>To accommodate, we define a pair of generic accessor operators that work through type-based dynamic dispatch: <code>(ref object field)</code>, and <code>(ref* object field1 field2 ...)</code> for chained access.</p>
<pre><code>(ref #(a b c) 1) ;=> b
(ref* #(a (x y #u8(1 2 3)) c) 1 2 0) ;=> 1</code></pre>
-<p>We define <code>~</code> as a synonym to <code>ref*</code>, and define an SRFI-17 setter for it.</p>
+<p>We define <code>~</code> as a synonym to <code>ref*</code>, and define a SRFI-17 setter for it.</p>
<pre><code>(define struct #(a (x y #u8(1 2 3)) c))
(set! (~ struct 1 2 0) 4)
struct ;=> #(a (x y #u8(4 2 3)) c)</code></pre>
diff --git a/srfi-123.md b/srfi-123.md
@@ -59,7 +59,7 @@ work through type-based dynamic dispatch: `(ref object field)`, and
(ref #(a b c) 1) ;=> b
(ref* #(a (x y #u8(1 2 3)) c) 1 2 0) ;=> 1
-We define `~` as a synonym to `ref*`, and define an SRFI-17 setter for
+We define `~` as a synonym to `ref*`, and define a SRFI-17 setter for
it.
(define struct #(a (x y #u8(1 2 3)) c))
diff --git a/tests/srfi-123.sld b/tests/srfi-123.sld
@@ -0,0 +1,102 @@
+;;; generic-ref-set --- Generic accessor and modifier operators.
+
+;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+
+;; Permission is hereby granted, free of charge, to any person obtaining
+;; a copy of this software and associated documentation files (the
+;; "Software"), to deal in the Software without restriction, including
+;; without limitation the rights to use, copy, modify, merge, publish,
+;; distribute, sublicense, and/or sell copies of the Software, and to
+;; permit persons to whom the Software is furnished to do so, subject to
+;; the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(define-library (tests srfi-123)
+ (export run-tests)
+ (import (except (scheme base) define-record-type set!)
+ (r6rs hashtables)
+ (srfi 64)
+ (srfi 123))
+ (cond-expand
+ ((library (srfi 4))
+ (import (srfi 4)))
+ (else))
+ (begin
+
+ (define-record-type <foo> (make-foo a b) foo?
+ (a foo-a set-foo-a!)
+ (b foo-b))
+
+ (define (run-tests)
+ (let ((runner (test-runner-create)))
+ (parameterize ((test-runner-current runner))
+ (test-begin "SRFI-123")
+
+ (test-begin "ref")
+ (test-assert "bytevector" (= 1 (ref (bytevector 0 1 2) 1)))
+ (test-assert "hashtable" (let ((table (make-eqv-hashtable)))
+ (hashtable-set! table 'foo 0)
+ (= 0 (ref table 'foo))))
+ (test-assert "hashtable default" (let ((table (make-eqv-hashtable)))
+ (= 1 (ref table 0 1))))
+ (test-assert "pair" (= 1 (ref (cons 0 1) 'cdr)))
+ (test-assert "list" (= 1 (ref (list 0 1 2) 1)))
+ (test-assert "string" (char=? #\b (ref "abc" 1)))
+ (test-assert "vector" (= 1 (ref (vector 0 1 2) 1)))
+ (test-assert "record" (= 1 (ref (make-foo 0 1) 'b)))
+ (test-skip (cond-expand ((library (srfi 4)) 0) (else 1)))
+ (test-assert "srfi-4" (= 1 (ref (s16vector 0 1 2) 1)))
+ (test-end "ref")
+
+ (test-assert "ref*" (= 1 (ref* '(_ #(_ (0 . 1) _) _) 1 1 'cdr)))
+
+ (test-begin "ref setter")
+ (test-assert "bytevector" (let ((bv (bytevector 0 1 2)))
+ (set! (ref bv 1) 3)
+ (= 3 (ref bv 1))))
+ (test-assert "hashtable" (let ((ht (make-eqv-hashtable)))
+ (set! (ref ht 'foo) 0)
+ (= 0 (ref ht 'foo))))
+ (test-assert "pair" (let ((p (cons 0 1)))
+ (set! (ref p 'cdr) 2)
+ (= 2 (ref p 'cdr))))
+ (test-assert "list" (let ((l (list 0 1 2)))
+ (set! (ref l 1) 3)
+ (= 3 (ref l 1))))
+ (test-assert "string" (let ((s (string #\a #\b #\c)))
+ (set! (ref s 1) #\d)
+ (char=? #\d (ref s 1))))
+ (test-assert "vector" (let ((v (vector 0 1 2)))
+ (set! (ref v 1) 3)
+ (= 3 (ref v 1))))
+ (test-assert "record" (let ((r (make-foo 0 1)))
+ (set! (ref r 'a) 2)
+ (= 2 (ref r 'a))))
+ (test-assert "bad record assignment"
+ (not (guard (err (else #f)) (set! (ref (make-foo 0 1) 'b) 2) #t)))
+ (test-skip (cond-expand ((library (srfi 4)) 0) (else 1)))
+ (test-assert "srfi-4" (let ((s16v (s16vector 0 1 2)))
+ (set! (ref s16v 1) 3)
+ (= 3 (ref s16v 1))))
+ (test-end "ref setter")
+
+ (test-assert "ref* setter"
+ (let ((obj (list '_ (vector '_ (cons 0 1) '_) '_)))
+ (set! (ref* obj 1 1 'cdr) 2)
+ (= 2 (ref* obj 1 1 'cdr))))
+
+ (test-end "SRFI-123")
+ (and (= 0 (test-runner-xpass-count runner))
+ (= 0 (test-runner-fail-count runner))))))
+
+ ))
