I was able to add the unit tests I had written to the r7rs-wip branch
and run them (patch is attached). The things that they tested mostly
worked out of the box, which is a good sign. Had to fix a couple
errors in some of the tests (checked the R7RS-small standard and my
tests were indeed in error).
Also, I found one error in the get-output-bytevector procedure in
(scheme base), which was that the procedure discarded the bytes
already written. get-output-bytevector is not supposed to be
destructive to the bytes already written, but the R6RS output
bytevector reading procedures are destructive. I made a patch with a
very simple fix, which is to just write the bytes back. It has one
major problem, though, and that is it is not threadsafe, so while it
is an improvement, there is still some more work to do on it.
Next thing I am going to do is copy over the docstrings I wrote for
code going to the bitbucket (my versions of the r7rs modules) to the
ones already in r7rs-wip since they are lacking docstrings.
Freja Nordsiek
On Tue, May 30, 2017 at 12:02 AM, Mark H Weaver <m...@netris.org> wrote:
> Hi Freja,
>
> Freja Nordsiek <fnord...@gmail.com> writes:
>
>> As far as splitting it into parts and discarding the scheme modules
>> and keeping the documentation, that sounds like a good idea. I just
>> did a quick perusal of the r7rs-wip branch and it does not seem to
>> have any R7RS unit tests. Did I miss any? If not, the test code, as
>> limited as it is, might also be useful.
>
> You didn't miss any. I agree that we need a good R7RS test suite. The
> tests you wrote could be a useful starting point, but clearly more
> coverage is needed.
>
> Some existing free R7RS Scheme implementations include test suites that
> we might be able to incorporate. Chibi Scheme includes one which I
> found useful while developing 'r7rs-wip', and as I vaguely recall there
> were at least two others. Kawa might have one.
>
> I think we should aim to adapt and incorporate one or more existing R7RS
> test suites from elsewhere, if the relevant licenses are favorable.
>
>> As for the question/puzzlement of why I wrote all of this, that is
>> complicated, and kind of silly in retrospect. The r7rs-wip branch
>> looked like it was most of the way to complete but was three years
>> behind the master branch and thus seemed like it was possibly dead for
>> unknown reasons [...]
>
>> Honestly, I should have just emailed the
>> list and what not and asked about the status of the r7rs-wip branch
>> and why it stalled, and then go from there (e.g. write the
>> documentation and possibly tests). I ended up duplicating a lot of
>> effort in a sloppy way.
>
> I can understand this. Unnecessarily rewriting code seems to be a
> common tendency in our community, and I confess that I've been known to
> do it myself. Hopefully the work had some educational value at least.
>
> I would guess that the overwhelming majority of the new Scheme code in
> 'r7rs-wip' does not depend on the C changes.
>
> I stalled on the 'r7rs-wip' work for a few reasons. For a couple of
> years, I had doubts about whether the R7RS should be promoted at all,
> given that it is gratuitously incompatible with the R6RS, which I
> consider to be more competently designed even though I disagree with
> some aspects of R6RS.
>
> Apart from that, I encountered difficulties implementing
> cyclic-data-aware R7RS 'write' and 'write-shared' in a way that's
> efficient, compatible with existing APIs (custom printers, print states,
> etc), and not too gross. I have an idea how to fix those issues, but
> haven't gotten around to implementing it yet.
>
> There are some details that are not yet addressed, e.g. supporting
> integers as components of module names, and deciding how to implement
> (library <library-name>) clauses in 'cond-expand'.
>
> Finally, the lack of a comprehensive test suite made me concerned that
> the code was not adequately tested.
>
>> I will split the documentation and possibly the tests out into their
>> own patches and modify them to work with r7rs-wip branch instead of
>> master branch.
>
> Thank you for your efforts!
>
> Mark
From 87aeea3162b6488a0bcee7b602314d60eba04342 Mon Sep 17 00:00:00 2001
From: Freja Nordsiek <fnord...@gmail.com>
Date: Sat, 17 Jun 2017 01:42:25 +0200
Subject: [PATCH] Added initial tests for R7RS-small.
* test-suite/Makefile.am: Added R7RS tests to the list.
* test-suite/tests/r7rs-base.test (new file): Tests for (scheme base).
* test-suite/tests/r7rs-char.test (new file): Tests for (scheme char).
* test-suite/tests/r7rs-lazy.test (new file): Tests for (scheme lazy).
* test-suite/tests/r7rs-time.test (new file): Tests for (scheme time).
---
test-suite/Makefile.am | 4 +
test-suite/tests/r7rs-base.test | 355 ++++++++++++++++++++++++++++++++++++++++
test-suite/tests/r7rs-char.test | 37 +++++
test-suite/tests/r7rs-lazy.test | 30 ++++
test-suite/tests/r7rs-time.test | 43 +++++
5 files changed, 469 insertions(+)
create mode 100644 test-suite/tests/r7rs-base.test
create mode 100644 test-suite/tests/r7rs-char.test
create mode 100644 test-suite/tests/r7rs-lazy.test
create mode 100644 test-suite/tests/r7rs-time.test
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index a050f83..1eb8dcf 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -114,6 +114,10 @@ SCM_TESTS = tests/00-initial-env.test \
tests/r6rs-records-syntactic.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
+ tests/r7rs-base.test \
+ tests/r7rs-char.test \
+ tests/r7rs-lazy.test \
+ tests/r7rs-time.test \
tests/ramap.test \
tests/rdelim.test \
tests/reader.test \
diff --git a/test-suite/tests/r7rs-base.test b/test-suite/tests/r7rs-base.test
new file mode 100644
index 0000000..e2e9dea
--- /dev/null
+++ b/test-suite/tests/r7rs-base.test
@@ -0,0 +1,355 @@
+;;; r7rs-base.test --- Test suite for R7RS (scheme base)
+
+;; Copyright (C) 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
+
+
+(define-module (test-suite test-r7rs-base)
+ :use-module ((scheme base))
+ :use-module ((scheme char))
+ :use-module ((scheme file))
+ :use-module ((rnrs bytevectors) #:select (bytevector->u8-list u8-list->bytevector))
+ :use-module ((rnrs io ports) #:select (port-position make-i/o-filename-error make-i/o-read-error))
+ :use-module ((srfi srfi-1))
+ :use-module (test-suite lib))
+
+
+(define thai-digits "\u0E50\u0E51\u0E52\u0E53\u0E54\u0E55\u0E56\u0E57\u0E58\u0E59")
+
+;;; Conversion gotten using CPython 3.5.2
+(define thai-digits-utf8 #vu8(224 185 144 224 185 145 224 185 146 224 185 147 224 185 148 224
+ 185 149 224 185 150 224 185 151 224 185 152 224 185 153))
+
+(define (grab-error thunk)
+ (let ((obj '()))
+ (guard (con ((= 1 1) (set! obj con))) (thunk))
+ obj))
+
+
+(with-test-prefix "read-error?"
+ (pass-if "read-error? true for i/o-read-error" (read-error? (make-i/o-read-error "hi")))
+ (pass-if "read-error? false for integer" (not (read-error? -4)))
+ (pass-if "read-error? false for file error" (not (read-error? (make-i/o-filename-error "hal")))))
+
+(with-test-prefix "file-error?"
+ (pass-if "file-error? true" (file-error? (make-i/o-filename-error "hal")))
+ (pass-if "file-error? false for integer" (not (file-error? -4)))
+ (pass-if "file-error? false for read error"
+ (not (file-error? (grab-error (lambda () (read "blaf8vhe")))))))
+
+(with-test-prefix "features"
+ (pass-if "features list" (list? (features)))
+ (pass-if "features equal to %cond-expand-features"
+ (list= symbol=? (features) %cond-expand-features)))
+
+(with-test-prefix "square"
+ (pass-if "square same as (* x x)"
+ (let ((nums (append '(8.0 3/4 -3.3 -8) (iota 100))))
+ (list= = (map square nums) (map (lambda (x) (* x x)) nums)))))
+
+(with-test-prefix "string->vector"
+ (pass-if "string->vector vector" (vector? (string->vector "aivi38vaAfva8hga#$")))
+ (pass-if "string->vector compare to string->list"
+ (let ((s "a9vaEAva88nn4 aaiavAv aieavafa==34\av aA#$a"))
+ (list= char=? (vector->list (string->vector s)) (string->list s)))))
+
+(with-test-prefix "vector->string"
+ (pass-if "vector->string string" (string? (vector->string #(#\a #\b #\c #\d))))
+ (pass-if "vector->string compare to vector->list"
+ (let ((v #(#\a #\5 #\E #\% #\space)))
+ (list= char=? (string->list (vector->string v)) (vector->list v)))))
+
+(with-test-prefix "string->utf8"
+ (pass-if "string->utf8 bytevector" (bytevector? (string->utf8 "a9v3naaviavaF#aavi3A\u0E59")))
+ (pass-if "string->utf8 ascii digits"
+ (list= = (bytevector->u8-list (string->utf8 "0123456789")) (iota 10 48)))
+ (pass-if "string->utf8 length increases for non-ascii"
+ (let ((s thai-digits))
+ (> (bytevector-length (string->utf8 s)) (string-length s)))))
+
+(with-test-prefix "utf8->string"
+ (pass-if "utf8->string string" (string? (utf8->string (u8-list->bytevector (iota 10 48)))))
+ (pass-if "utf8->string length decreases for non-ascii"
+ (let ((bv thai-digits-utf8))
+ (> (bytevector-length bv) (string-length (utf8->string bv)))))
+ (pass-if "utf8->string works for Thai digits"
+ (string=? (utf8->string thai-digits-utf8) thai-digits)))
+
+(with-test-prefix "string-map"
+ (pass-if "string-map char-downcase"
+ (let ((s "aavieEAIVAeaneai#aa9va#$"))
+ (string=? (string-map char-downcase s) (string-downcase s))))
+ (pass-if "string-map selective char grab"
+ (let ((s1 "ueANezvfiHviae")
+ (s2 "UEanEZVFIhVIAE"))
+ (string=? (string-upcase s1) (string-map (lambda (x y) (if (char>? x y) y x)) s1 s2)))))
+
+(with-test-prefix "string-for-each"
+ (pass-if "string-for-each look for char"
+ (let ((s "avienfvavRau3$ava8vae#Afa")
+ (chr #\R)
+ (found #f))
+ (string-for-each (lambda (c)(if (char=? chr c) (set! found #t))) s)
+ found)))
+
+(with-test-prefix "bytevector"
+ (pass-if "bytevector bytevector" (bytevector? (bytevector 3 9 32 204)))
+ (pass-if "bytevector apply to u8 list"
+ (let ((lst '(3 48 110 30 253 0)))
+ (list= = (bytevector->u8-list (apply bytevector lst)) lst))))
+
+(with-test-prefix "bytevector-append"
+ (pass-if "bytevector-append bytevector" (bytevector? (bytevector-append #vu8(3 2) #vu8(90))))
+ (pass-if "bytevector-append three u8 lists"
+ (let ((lst1 '(38 8 20 0 255))
+ (lst2 '(82))
+ (lst3 '(5 9 200 138)))
+ (list= = (append lst1 lst2 lst3)
+ (bytevector->u8-list (bytevector-append (u8-list->bytevector lst1)
+ (u8-list->bytevector lst2)
+ (u8-list->bytevector lst3)))))))
+
+(with-test-prefix "bytevector-copy!"
+ (pass-if "bytevector-copy!"
+ (let ((bv-t #vu8(0 0 0 0 0 0 0 0))
+ (bv-s #vu8(1 2 3))
+ (bv-r #vu8(0 0 0 1 2 3 0 0)))
+ (bytevector-copy! bv-t 3 bv-s)
+ (list= = (bytevector->u8-list bv-t) (bytevector->u8-list bv-r))))
+ (pass-if "bytevector-copy! with source-start"
+ (let ((bv-t #vu8(0 0 0 0 0 0 0 0))
+ (bv-s #vu8(1 2 3))
+ (bv-r #vu8(0 0 0 2 3 0 0 0)))
+ (bytevector-copy! bv-t 3 bv-s 1)
+ (list= = (bytevector->u8-list bv-t) (bytevector->u8-list bv-r))))
+ (pass-if "bytevector-copy! with source-start and source-end"
+ (let ((bv-t #vu8(0 0 0 0 0 0 0 0))
+ (bv-s #vu8(1 2 3))
+ (bv-r #vu8(0 0 0 2 0 0 0 0)))
+ (bytevector-copy! bv-t 3 bv-s 1 2)
+ (list= = (bytevector->u8-list bv-t) (bytevector->u8-list bv-r)))))
+
+(with-test-prefix "bytevector output port"
+ (pass-if "open-output-bytevector open binary output port"
+ (let ((p (open-output-bytevector)))
+ (and (port? p) (output-port? p) (binary-port? p) (not (port-closed? p)))))
+ (pass-if "get-output-bytevector bytevector"
+ (bytevector? (get-output-bytevector (open-output-bytevector))))
+ (pass-if "write and read back"
+ (let ((p (open-output-bytevector))
+ (bv (u8-list->bytevector (iota 256))))
+ (write-bytevector bv p)
+ ;; Compare twice to make sure get-output-bytevector doesn't cause
+ ;; bytevector output port to be cleared.
+ (let ((read1 (get-output-bytevector p))
+ (read2 (get-output-bytevector p)))
+ (close-port p)
+ (and (list= = (bytevector->u8-list bv) (bytevector->u8-list read1))
+ (list= = (bytevector->u8-list bv) (bytevector->u8-list read2)))))))
+
+(with-test-prefix "input-port-open?"
+ (pass-if "input-port-open? true on open input port"
+ (boolean=? #t (input-port-open? (open-input-string "abeeU"))))
+ (pass-if "input-port-open? false on closed input port"
+ (let ((p (open-input-string "avie$av9a")))
+ (close-port p)
+ (boolean=? #f (input-port-open? p))))
+ (pass-if "input-port-open? false on output port"
+ (call/cc
+ (lambda (cont)
+ (with-exception-handler (lambda (a) (cont #t))
+ (lambda () (cont (boolean=? #f (input-port-open? (open-output-string)))))))))
+ (pass-if "input-port-open? error or false on integer"
+ (call/cc
+ (lambda (cont)
+ (with-exception-handler (lambda (a) (cont #t))
+ (lambda () (cont (boolean=? #f (input-port-open? 3)))))))))
+
+(with-test-prefix "output-port-open?"
+ (pass-if "output-port-open? true on open output port"
+ (boolean=? #t (output-port-open? (open-output-string))))
+ (pass-if "output-port-open? false on closed output port"
+ (let ((p (open-output-string)))
+ (close-port p)
+ (boolean=? #f (output-port-open? p))))
+ (pass-if "output-port-open? false on input port"
+ (call/cc
+ (lambda (cont)
+ (with-exception-handler (lambda (a) (cont #t))
+ (lambda () (cont (boolean=? #f (output-port-open? (open-input-string)))))))))
+ (pass-if "output-port-open? error or false on integer"
+ (call/cc
+ (lambda (cont)
+ (with-exception-handler (lambda (a) (cont #t))
+ (lambda () (cont (boolean=? #f (output-port-open? 3)))))))))
+
+(with-test-prefix "peek-u8"
+ (pass-if "peek-u8 read byte and doesn't advance"
+ (let* ((bv #vu8(239 39 184 94 38))
+ (p (open-input-bytevector bv))
+ (value (peek-u8 p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (= pos 0) (= value (bytevector-u8-ref bv 0))))))
+
+(with-test-prefix "read-u8"
+ (pass-if "read-u8 read byte and does advance"
+ (let* ((bv #vu8(239 39 184 94 38))
+ (p (open-input-bytevector bv))
+ (value (read-u8 p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (= pos 1) (= value (bytevector-u8-ref bv 0))))))
+
+(with-test-prefix "write-u8"
+ (pass-if "write-u8 write byte and does advance"
+ (let ((value 47)
+ (p (open-output-bytevector)))
+ (write-u8 value p)
+ (and (= (port-position p) 1)
+ (list= = (list value) (bytevector->u8-list (get-output-bytevector p)))))))
+
+(with-test-prefix "read-bytevector"
+ (pass-if "read-bytevector read correctly"
+ (let* ((bv #vu8(239 39 184 94 38))
+ (num-to-read 3)
+ (p (open-input-bytevector bv))
+ (value (read-bytevector num-to-read p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (= pos num-to-read) (list= = (bytevector->u8-list value)
+ (list-head (bytevector->u8-list bv) num-to-read))))))
+
+(with-test-prefix "read-bytevector!"
+ (pass-if "read-bytevector! read"
+ (let* ((bv-s #vu8(1 2 3 4 5 6))
+ (bv-t #vu8(0 0 0))
+ (bv-correct #vu8(1 2 3))
+ (p (open-input-bytevector bv-s))
+ (num-read (read-bytevector! bv-t p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (list= = (bytevector->u8-list bv-t) (bytevector->u8-list bv-correct))
+ (= pos num-read)
+ (= num-read (bytevector-length bv-t)))))
+ (pass-if "read-bytevector! read with start"
+ (let* ((bv-s #vu8(1 2 3 4 5 6))
+ (bv-t #vu8(0 0 0))
+ (bv-correct #vu8(0 1 2))
+ (p (open-input-bytevector bv-s))
+ (num-read (read-bytevector! bv-t p 1))
+ (pos (port-position p)))
+ (close-port p)
+ (and (list= = (bytevector->u8-list bv-t) (bytevector->u8-list bv-correct))
+ (= pos num-read)
+ (= (+ 1 num-read) (bytevector-length bv-t)))))
+ (pass-if "read-bytevector! read with start and end"
+ (let* ((bv-s #vu8(1 2 3 4 5 6))
+ (bv-t #vu8(0 0 0))
+ (bv-correct #vu8(0 1 0))
+ (p (open-input-bytevector bv-s))
+ (num-read (read-bytevector! bv-t p 1 2))
+ (pos (port-position p)))
+ (close-port p)
+ (and (list= = (bytevector->u8-list bv-t) (bytevector->u8-list bv-correct))
+ (= pos num-read)
+ (= (+ 2 num-read) (bytevector-length bv-t))))))
+
+(with-test-prefix "write-bytevector"
+ (pass-if "write-bytevector write"
+ (let ((bv #vu8(1 2 3 4 5 6))
+ (bv-correct #vu8(1 2 3 4 5 6))
+ (p (open-output-bytevector)))
+ (write-bytevector bv p)
+ (and (list= = (bytevector->u8-list (get-output-bytevector p))
+ (bytevector->u8-list bv-correct))
+ (= (port-position p) (bytevector-length bv-correct)))))
+ (pass-if "write-bytevector write with start"
+ (let ((bv #vu8(1 2 3 4 5 6))
+ (bv-correct #vu8(3 4 5 6))
+ (p (open-output-bytevector)))
+ (write-bytevector bv p 2)
+ (and (list= = (bytevector->u8-list (get-output-bytevector p))
+ (bytevector->u8-list bv-correct))
+ (= (port-position p) (bytevector-length bv-correct)))))
+ (pass-if "write-bytevector write with start and end"
+ (let ((bv #vu8(1 2 3 4 5 6))
+ (bv-correct #vu8(3 4 5))
+ (p (open-output-bytevector)))
+ (write-bytevector bv p 2 5)
+ (and (list= = (bytevector->u8-list (get-output-bytevector p))
+ (bytevector->u8-list bv-correct))
+ (= (port-position p) (bytevector-length bv-correct))))))
+
+(with-test-prefix "read-string"
+ (pass-if "read-string read"
+ (let* ((str-s "aiviEenvae")
+ (count 5)
+ (str-correct "aiviE")
+ (p (open-input-string str-s))
+ (str-out (read-string count p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (string=? str-out str-correct) (= count (string-length str-out)) (= count pos)))))
+
+(with-test-prefix "write-string"
+ (pass-if "write-string write"
+ (let* ((str-s "a*viRaiv")
+ (str-correct str-s)
+ (p (open-output-string)))
+ (write-string str-s p)
+ (let ((str-out (get-output-string p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (string=? str-out str-correct) (= pos (string-length str-out))))))
+ (pass-if "write-string write with start"
+ (let ((str-s "a*viRaiv")
+ (str-correct "iRaiv")
+ (p (open-output-string)))
+ (write-string str-s p 3)
+ (let ((str-out (get-output-string p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (string=? str-out str-correct) (= pos (string-length str-out))))))
+ (pass-if "write-string write with start and end"
+ (let ((str-s "a*viRaiv")
+ (str-correct "iRa")
+ (p (open-output-string)))
+ (write-string str-s p 3 6)
+ (let ((str-out (get-output-string p))
+ (pos (port-position p)))
+ (close-port p)
+ (and (string=? str-out str-correct) (= pos (string-length str-out)))))))
+
+(with-test-prefix "read-line"
+ (pass-if "read-line read"
+ (let ((p (open-output-string)))
+ (newline p)
+ (let ((linefeed (get-output-string p))
+ (line1 "avaie$Ava 3fai")
+ (line2 "vi38va$#ava aaf ")
+ (po (open-output-string)))
+ (write-string line1 po)
+ (newline po)
+ (write-string line2 po)
+ (newline po)
+ (let* ((str-intermediate (get-output-string po))
+ (pi (open-input-string str-intermediate))
+ (str-out (read-line pi)))
+ (close-port p)
+ (close-port po)
+ (close-port pi)
+ (string=? str-out line1))))))
diff --git a/test-suite/tests/r7rs-char.test b/test-suite/tests/r7rs-char.test
new file mode 100644
index 0000000..722b756
--- /dev/null
+++ b/test-suite/tests/r7rs-char.test
@@ -0,0 +1,37 @@
+;;; r7rs-char.test --- Test suite for R7RS (scheme char)
+
+;; Copyright (C) 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
+
+
+(define-module (test-suite test-r7rs-char)
+ :use-module ((scheme char))
+ :use-module ((srfi srfi-1))
+ :use-module (test-suite lib))
+
+
+(define (test-zero-to-nine s)
+ (every equal? (iota 10) (map digit-value (string->list s))))
+
+(with-test-prefix "digit-value"
+ (pass-if "digit-values true on ascii digits" (test-zero-to-nine "0123456789"))
+ (pass-if "digit-values true on Thai digits"
+ (test-zero-to-nine "\u0E50\u0E51\u0E52\u0E53\u0E54\u0E55\u0E56\u0E57\u0E58\u0E59"))
+ (pass-if "digit-values false on ascii letters"
+ (not (any digit-value
+ (string->list "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))))
+ (pass-if "digit-values false on whitespace"
+ (not (any digit-value (char-set->list char-set:whitespace)))))
diff --git a/test-suite/tests/r7rs-lazy.test b/test-suite/tests/r7rs-lazy.test
new file mode 100644
index 0000000..d8156f5
--- /dev/null
+++ b/test-suite/tests/r7rs-lazy.test
@@ -0,0 +1,30 @@
+;;; r7rs-lazy.test --- Test suite for R7RS (scheme lazy)
+
+;; Copyright (C) 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
+
+
+(define-module (test-suite test-r7rs-lazy)
+ :use-module ((scheme lazy) #:select ((delay . sl-delay) (promise? . sl-promise?)
+ (make-promise . sl-make-promise) (force . sl-force)))
+ :use-module (test-suite lib))
+
+
+(with-test-prefix "make-promise"
+ (pass-if "make-promise on integer" (sl-promise? (sl-make-promise 3)))
+ (pass-if "make-promise on promise"
+ (let ((p (sl-delay (+ 3.28832193 8))))
+ (and (sl-promise? p) (inexact? (sl-force p))))))
diff --git a/test-suite/tests/r7rs-time.test b/test-suite/tests/r7rs-time.test
new file mode 100644
index 0000000..6453128
--- /dev/null
+++ b/test-suite/tests/r7rs-time.test
@@ -0,0 +1,43 @@
+;;; r7rs-time.test --- Test suite for R7RS (scheme time)
+
+;; Copyright (C) 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
+
+
+(define-module (test-suite test-r7rs-time)
+ :use-module ((scheme time))
+ :use-module (test-suite lib))
+
+
+(with-test-prefix "jiffies-per-second"
+ (pass-if "jiffies-per-second integer" (integer? (jiffies-per-second)))
+ (pass-if "jiffies-per-second positive" (> (jiffies-per-second) 0)))
+
+(with-test-prefix "current-second"
+ (pass-if "current-second inexact" (inexact? (current-second)))
+ (pass-if "current-second increasing"
+ (let ((first-time (current-second)))
+ (sleep 2)
+ (let ((second-time (current-second)))
+ (< first-time second-time)))))
+
+(with-test-prefix "current-jiffy"
+ (pass-if "current-jiffy exact" (exact? (current-jiffy)))
+ (pass-if "current-jiffy increasing"
+ (let ((first-time (current-jiffy)))
+ (sleep 2)
+ (let ((second-time (current-jiffy)))
+ (< first-time second-time)))))
--
2.9.4
From 19b888ab32d4eee4deb193853faa9061ca9058ac Mon Sep 17 00:00:00 2001
From: Freja Nordsiek <fnord...@gmail.com>
Date: Sat, 17 Jun 2017 01:45:19 +0200
Subject: [PATCH] Fixed get-output-bytevector discarding already written bytes
bug.
* module/scheme/base.scm (get-output-bytevector): Fixed bug where bytes already
written were cleared.
---
module/scheme/base.scm | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 97fbc5d..b851be3 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -390,7 +390,9 @@
(let ((proc (%port-property port 'get-output-bytevector)))
(unless proc
(error "get-output-bytevector: port not created by open-output-bytevector"))
- (proc)))
+ (let ((out (proc)))
+ (write-bytevector out port)
+ out)))
(define* (peek-u8 #:optional (port (current-input-port)))
(lookahead-u8 port))
--
2.9.4
