~ chicken-r7rs (master) e2f4e1782efd2ae75583f6c8c9b40a5c8f64af04
commit e2f4e1782efd2ae75583f6c8c9b40a5c8f64af04
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Jan 16 07:35:01 2014 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Jan 16 07:35:01 2014 +0000
Most of scheme.base, stub rest of libs, define-library/inclusion fixes
diff --git a/NOTES.org b/NOTES.org
index 70891db..d370938 100644
--- a/NOTES.org
+++ b/NOTES.org
@@ -5,15 +5,27 @@ NOTES
- possible reimplement using core functionality.
* Use of "define-values" is elegant but loses lambda-info for the defined procedures.
+ - Removed.
* "export" does not support "(rename ...)" specifier yet.
- this needs extensions to the core module system.
* "(import SYMBOL)" is currently allowed. Should it not?
+ - I think this is needed for backwards compatibility (when an R7RS module imports a non-R7RS module).
* Redefinition of "import" causes "re-importing" warnings.
- The warnings could be removed in core, it's usefulness is not completely clear.
-* Just renaming procedures (like from srfi-4) doesn't change their lambda-info names.
- - This is sort of confusing, do we care (or should we "(define new old)")?
+* Just reexporting procedures (like from srfi-4) doesn't change their lambda-info names.
+ - This is sort of confusing, do we care?
- Also, this makes the locations from errors (from ##sys#check-whatever) wrong/misleading.
+
+* Should bytevectors be implemented over blobs instead of srfi-4 (or something else)?
+
+* I think library forms (i.e. ".sld" files) should look for includes relative to themselves
+ - not sure how to get that info when expanding define-library
+
+* UTF8? Not required, but should (use r7rs) include this extension, like it includes numbers?
+
+* get-environment-variable: "It is also an error to mutate the resulting string" ...
+ - can we just ignore this?
diff --git a/r7rs-compile-time.scm b/r7rs-compile-time.scm
index 5a74cfa..ad24c86 100644
--- a/r7rs-compile-time.scm
+++ b/r7rs-compile-time.scm
@@ -4,7 +4,6 @@
(import matchable)
(use srfi-1 files extras data-structures)
-
(define (parse-library-name name loc)
(define (fail) (syntax-error loc "invalid library name" name))
(match name
@@ -29,7 +28,8 @@
;;XXX scan include-path?
(let* ((name2 (parse-library-name name loc))
(sname2 (symbol->string name2)))
- (or (file-exists? (string-append sname2 ".import.so"))
+ (or (##sys#provided? name2)
+ (file-exists? (string-append sname2 ".import.so"))
(file-exists? (string-append sname2 ".import.scm"))
(extension-information name2))))
@@ -93,19 +93,9 @@
`(##core#require-extension (,name) #f))))
(strip-syntax (cdr x))))))))
-(define (current-source-directory)
- (pathname-directory
- (or (and (feature? #:compiling) ##compiler#source-filename)
- ##sys#current-source-filename)))
-
(define (read-forms filename ci?)
- (read-file
- (if (absolute-pathname? filename)
- filename
- (make-pathname (current-source-directory) filename))
- (lambda (port)
- (parameterize ((case-sensitive ci?))
- (read port)))))
+ (parameterize ((case-sensitive (not ci?)))
+ (##sys#include-forms-from-file filename)))
(define (parse-library-definition form dummy-export) ; expects stripped syntax
(match form
@@ -148,11 +138,11 @@
,(parse-decls more)))
((('include fnames ...) . more)
`(##core#begin
- ,@(process-includes fnames #f)
+ ,(process-includes fnames #f)
,(parse-decls more)))
((('include-ci fnames ...) . more)
`(##core#begin
- ,@(process-includes fnames #t)
+ ,(process-includes fnames #t)
,(parse-decls more)))
((('include-library-declarations fnames ...) . more)
`(##core#begin
@@ -164,7 +154,7 @@
,(parse-decls more)))
((('begin code ...) . more)
`(##core#begin
- (##core#begin ,@code)
+ ,@code
,(parse-decls more)))
(decl (syntax-error 'define-library "invalid library declaration" decl))))
`(##core#begin
diff --git a/r7rs.scm b/r7rs.scm
index 54c7ac3..7615d70 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -1,14 +1,16 @@
(module r7rs (define-library import import-for-syntax export syntax-rules)
(import (except scheme syntax-rules)) ;XXX except ...
- (import (only chicken include)) ;XXX except ...
+ (import (only chicken feature? include)) ;XXX except ...
;; For syntax definition helpers.
(import-for-syntax r7rs-compile-time matchable)
(begin-for-syntax (require-library r7rs-compile-time))
;; For extended number literals.
- (require-library numbers)
+ (if (feature? 'compiler-extension)
+ (require-library numbers-syntax)
+ (require-extension numbers))
;; For #u8(...) syntax.
(require-extension srfi-4)
diff --git a/r7rs.setup b/r7rs.setup
index 13c8073..b6f72f1 100644
--- a/r7rs.setup
+++ b/r7rs.setup
@@ -4,7 +4,7 @@
(use make srfi-1)
(define scheme-modules
- '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "load" "process-context" "r5rs" "read" "write")) ;XXX
+ '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "lazy" "load" "process-context" "r5rs" "read" "repl" "time" "write")) ;XXX
(make (("r7rs-compile-time.so" ("r7rs-compile-time.scm" "r7rs-compile-time-module.scm")
(compile -s -O3 -d1 r7rs-compile-time-module.scm -J -o r7rs-compile-time.so)
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 26a2c94..c6e9cab 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -7,9 +7,7 @@
apply
assoc assq assv
begin
- #|
- binary-port?
- |#
+ binary-port? ; XXX
boolean? boolean=?
bytevector
bytevector-append
@@ -68,12 +66,10 @@
if
#|
import ; provided by the "r7rs" module
- import-for-syntax ; XXX should we? Probably not, it's not in r7rs...
+ import-for-syntax ; same
|#
include
- #|
include-ci
- |#
input-port-open? output-port-open?
input-port? output-port?
integer?
@@ -83,9 +79,6 @@
letrec letrec*
let-values let*-values
let-syntax letrec-syntax
- #|
- library ; for "cond-expand"
- |#
list list-copy list-ref list-set! list-tail list?
list->vector
make-bytevector
@@ -111,9 +104,7 @@
pair?
parameterize
peek-char
- #|
peek-u8
- |#
port?
procedure?
quasiquote
@@ -122,16 +113,12 @@
raise raise-continuable
rational?
rationalize
- #|
read-bytevector read-bytevector!
- |#
read-char
read-error?
- #|
read-line
read-string
read-u8
- |#
real?
reverse
round
@@ -140,67 +127,49 @@
square
string
string->list list->string
- #|
string->utf8 utf8->string
- |#
string->symbol symbol->string
- #|
string->vector
- |#
string-append
string-copy
- #|
string-copy!
- |#
string-fill!
- #|
string-for-each
- |#
string-length
- #|
string-map
- |#
string-ref string-set!
string=? string<? string>? string<=? string>=?
string?
- substring
- #|
symbol=?
- |#
symbol?
syntax-error
#|
- syntax-rules
- textual-port?
+ syntax-rules ; provided by the "r7rs" module
|#
+ textual-port? ; XXX
truncate
truncate/ truncate-quotient truncate-remainder
- #|
u8-ready?
- |#
unless
#|
- unquote unquote-splicing
+ unquote unquote-splicing ; provided by `quasiquote`
|#
values
vector
- #|
vector-append
vector-copy vector-copy!
vector-for-each
vector-length
vector-map
- |#
vector-ref vector-set!
+ vector->list
+ vector->string
+ vector?
when
with-exception-handler
- #|
write-bytevector
- |#
write-char
- #|
write-string
write-u8
- |#
zero?
)
diff --git a/scheme.base.scm b/scheme.base.scm
index ec4e8f0..dd4001f 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,43 +1,71 @@
(module scheme.base ()
-(import (except scheme syntax-rules cond-expand include
+(import (except chicken with-exception-handler include
+ quotient remainder modulo vector-copy!))
+(import (except scheme syntax-rules cond-expand
assoc list-set! list-tail member
char=? char<? char>? char<=? char>=?
- string=? string<? string>? string<=? string>=?))
+ string=? string<? string>? string<=? string>=?
+ string-copy string->list
+ vector->list))
(import (prefix (only scheme char=? char<? char>? char<=? char>=?
string=? string<? string>? string<=? string>=?)
%))
-(import (except chicken with-exception-handler raise include quotient remainder modulo))
(import (rename (only chicken include) (include %include)))
-(import (rename (only srfi-4 ; TODO: utf8<->string
- make-u8vector subu8vector u8vector u8vector?
- u8vector-length u8vector-ref u8vector-set!)
- (u8vector? bytevector?)
- (make-u8vector make-bytevector)
+(import (rename (only srfi-4 make-u8vector subu8vector u8vector u8vector?
+ u8vector-length u8vector-ref u8vector-set!
+ read-u8vector read-u8vector! write-u8vector)
(u8vector bytevector)
(u8vector-length bytevector-length)
(u8vector-ref bytevector-u8-ref)
- (u8vector-set! bytevector-u8-set!)))
+ (u8vector-set! bytevector-u8-set!)
+ (u8vector? bytevector?)
+ (make-u8vector make-bytevector)
+ (write-u8vector write-bytevector)))
(%include "scheme.base-interface.scm")
+;; For syntax definition helpers.
(begin-for-syntax (require-library r7rs-compile-time))
(import-for-syntax r7rs-compile-time)
(import r7rs-compile-time)
(import numbers)
+;; read/write-string/line/byte
+(require-library extras)
+(import (prefix (only extras read-string write-string) %))
+(import (rename (only extras read-line read-byte write-byte)
+ (read-byte read-u8)
+ (write-byte write-u8)))
+
+;; flush-output
+(import (rename (only chicken flush-output)
+ (flush-output flush-output-port)))
+
+;; u8-ready?
+(import (rename (only scheme char-ready?)
+ (char-ready? u8-ready?)))
+
+;; Non-R5RS string-*
+(require-library srfi-13)
+(import (prefix (only srfi-13 string-for-each string-map) %))
+(import (only srfi-13 string-copy string-copy! string-fill! string->list))
+
;;;
;;; 4.1.7. Inclusion
;;;
(define-syntax include
- (syntax-rules ()
- ((_ str)
- (%include str))
- ((_ str . rest)
- (begin
- (%include str)
- (include . rest)))))
+ (er-macro-transformer
+ (lambda (e r c)
+ (cons (r 'begin)
+ (append-map (cut read-forms <> #f) (cdr e))))))
+
+(define-syntax include-ci
+ (er-macro-transformer
+ (lambda (e r c)
+ (cons (r 'begin)
+ (append-map (cut read-forms <> #t) (cdr e))))))
;;;
;;; 4.2.1. Conditionals
@@ -117,7 +145,7 @@
;;; 6.2.6 Numerical operations
;;;
-(: square (number --> number))
+(: square (number -> number))
(define (square n) (* n n))
@@ -240,6 +268,14 @@
(##sys#fast-reverse res)
(lp (cons (car lst) res) (cdr lst)))))
+;;;
+;;; 6.5 Symbols
+;;;
+
+(: symbol=? (symbol symbol #!rest symbol -> boolean))
+
+(define-extended-arity-comparator symbol=? eqv? ##sys#check-symbol)
+
;;;
;;; 6.6 Characters
;;;
@@ -272,63 +308,287 @@
(define-extended-arity-comparator string<=? %string<=? ##sys#check-string)
(define-extended-arity-comparator string>=? %string>=? ##sys#check-string)
+(: string->vector (string #!optional fixnum fixnum -> (vector-of char)))
+(: vector->string ((vector-of char) #!optional fixnum fixnum -> string))
+
+(define string->vector
+ (let ((s->v (lambda (s start . end)
+ (##sys#check-string s 'string->vector)
+ (let* ((len (##sys#size s))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'string->vector)
+ (##sys#check-range end start (fx+ len 1) 'string->vector)
+ (let ((v (##sys#make-vector (fx- end start))))
+ (do ((ti 0 (fx+ ti 1))
+ (fi start (fx+ fi 1)))
+ ((fx= fi end) v)
+ (##sys#setslot v ti (##core#inline "C_subchar" s fi))))))))
+ (case-lambda
+ ((s) (s->v s 0))
+ ((s start) (s->v s start))
+ ((s start end) (s->v s start end)))))
+
+(define vector->string
+ (let ((v->s (lambda (v start . end)
+ (##sys#check-vector v 'vector->string)
+ (let* ((len (##sys#size v))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'vector->string)
+ (##sys#check-range end start (fx+ len 1) 'vector->string)
+ (let ((s (##sys#make-string (fx- end start))))
+ (do ((ti 0 (fx+ ti 1))
+ (fi start (fx+ fi 1)))
+ ((fx= fi end) s)
+ (let ((c (##sys#slot v fi)))
+ (##sys#check-char c 'vector->string)
+ (##core#inline "C_setsubchar" s ti c))))))))
+ (case-lambda
+ ((v) (v->s v 0))
+ ((v start) (v->s v start))
+ ((v start end) (v->s v start end)))))
+
+;;;
+;;; 6.8. Vectors
+;;;
+
+(: vector-append (#!rest vector -> vector))
+(: vector-copy (forall (a) ((vector-of a) #!optional fixnum fixnum -> (vector-of a))))
+(: vector-copy! (vector fixnum vector #!optional fixnum fixnum -> undefined))
+(: vector->list (forall (a) ((vector-of a) #!optional fixnum fixnum -> (list-of a))))
+
+(define vector-copy
+ (let ((copy (lambda (v start . end)
+ (##sys#check-vector v 'vector-copy)
+ (let* ((len (##sys#size v))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'vector-copy)
+ (##sys#check-range end start (fx+ len 1) 'vector-copy)
+ (let ((vec (##sys#make-vector (fx- end start))))
+ (do ((ti 0 (fx+ ti 1))
+ (fi start (fx+ fi 1)))
+ ((fx>= fi end) vec)
+ (##sys#setslot vec ti (##sys#slot v fi))))))))
+ (case-lambda
+ ((v) (copy v 0))
+ ((v start) (copy v start))
+ ((v start end) (copy v start end)))))
+
+(define vector-copy!
+ (let ((copy! (lambda (to at from start . end)
+ (##sys#check-vector to 'vector-copy!)
+ (##sys#check-vector from 'vector-copy!)
+ (let* ((tlen (##sys#size to))
+ (flen (##sys#size from))
+ (end (optional end flen)))
+ (##sys#check-range at 0 (fx+ tlen 1) 'vector-copy!)
+ (##sys#check-range start 0 (fx+ end 1) 'vector-copy!)
+ (##sys#check-range end start (fx+ flen 1) 'vector-copy!)
+ (##sys#check-range (fx- end start) 0 (fx+ (fx- tlen at) 1) 'vector-copy!)
+ (do ((fi start (fx+ fi 1))
+ (ti at (fx+ ti 1)))
+ ((fx= fi end))
+ (##sys#setslot to ti (##sys#slot from fi)))))))
+ (case-lambda
+ ((to at from) (copy! to at from 0))
+ ((to at from start) (copy! to at from start))
+ ((to at from start end) (copy! to at from start end)))))
+
+(define vector->list
+ (let ((v->l (lambda (v start . end)
+ (##sys#check-vector v 'vector->list)
+ (let* ((len (##sys#size v))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'vector->list)
+ (##sys#check-range end start (fx+ len 1) 'vector->list)
+ (do ((i start (fx+ i 1))
+ (l '() (cons (##sys#slot v i) l)))
+ ((fx= i end) (##sys#fast-reverse l)))))))
+ (case-lambda
+ ((v) (v->l v 0))
+ ((v start) (v->l v start))
+ ((v start end) (v->l v start end)))))
+
+(define (vector-append . vs)
+ (##sys#for-each (cut ##sys#check-vector <> 'vector-append) vs)
+ (let* ((lens (map ##sys#size vs))
+ (vec (##sys#make-vector (foldl fx+ 0 lens))))
+ (do ((vs vs (cdr vs))
+ (lens lens (cdr lens))
+ (i 0 (fx+ i (car lens))))
+ ((null? vs) vec)
+ (vector-copy! vec i (car vs) 0 (car lens)))))
+
;;;
;;; 6.9. Bytevectors
;;;
(define-type bytevector u8vector)
+(: bytevector (#!rest fixnum -> bytevector))
+(: bytevector-append (#!rest bytevector -> bytevector))
(: bytevector-copy (bytevector #!optional fixnum fixnum -> bytevector))
+(: bytevector-copy! (bytevector fixnum bytevector #!optional fixnum fixnum -> undefined))
+(: bytevector-length (bytevector -> fixnum))
+(: bytevector-u8-ref (bytevector fixnum -> fixnum))
+(: bytevector-u8-set! (bytevector fixnum fixnum -> void))
+(: bytevector? (* -> boolean : bytevector))
+(: make-bytevector (fixnum #!optional fixnum -> bytevector))
+(: string->utf8 (string #!optional fixnum fixnum -> bytevector))
+(: utf8->string (bytevector #!optional fixnum fixnum -> string))
+(: write-bytevector (bytevector #!optional output-port -> fixnum))
(define bytevector-copy
(case-lambda
- ((v) (bytevector-copy v 0 (bytevector-length v)))
- ((v s) (bytevector-copy v s (bytevector-length v)))
- ((v s e)
- (##sys#check-structure v 'u8vector 'bytevector-copy)
- (##sys#check-exact s 'bytevector-copy)
- (##sys#check-exact e 'bytevector-copy)
- (unless (and (fx<= 0 s) (fx<= s e) (fx<= e (bytevector-length v)))
- (error 'bytevector-copy "invalid indices" s e))
- (subu8vector v s e))))
-
-(: bytevector-copy! (bytevector fixnum bytevector #!optional fixnum fixnum -> undefined))
+ ((bv)
+ (##sys#check-structure bv 'u8vector 'bytevector-copy)
+ (subu8vector bv 0 (bytevector-length bv)))
+ ((bv start)
+ (##sys#check-structure bv 'u8vector 'bytevector-copy)
+ (subu8vector bv start (bytevector-length bv)))
+ ((bv start end)
+ (subu8vector bv start end))))
(define bytevector-copy!
- (case-lambda
- ((t a f) (bytevector-copy! t a f 0 (bytevector-length f)))
- ((t a f s) (bytevector-copy! t a f s (bytevector-length f)))
- ((t a f s e)
- (##sys#check-structure t 'u8vector 'bytevector-copy!)
- (##sys#check-structure f 'u8vector 'bytevector-copy!)
- (##sys#check-exact a 'bytevector-copy)
- (##sys#check-exact s 'bytevector-copy)
- (##sys#check-exact e 'bytevector-copy)
- (unless (and (fx<= 0 a)
- (fx<= 0 s)
- (fx<= e (bytevector-length f))
- (fx<= (fx- e s) (fx- (bytevector-length t) a)))
- (error 'bytevector-copy! "invalid indices" a s e))
- (do ((s s (fx+ s 1))
- (a a (fx+ a 1)))
- ((fx= s e))
- (bytevector-u8-set! t a (bytevector-u8-ref f s))))))
+ (let ((copy! (lambda (to at from start . end)
+ (##sys#check-structure to 'u8vector 'bytevector-copy!)
+ (##sys#check-structure from 'u8vector 'bytevector-copy!)
+ (let* ((tlen (bytevector-length to))
+ (flen (bytevector-length from))
+ (end (optional end flen)))
+ (##sys#check-range at 0 (fx+ tlen 1) 'bytevector-copy!)
+ (##sys#check-range start 0 (fx+ end 1) 'bytevector-copy!)
+ (##sys#check-range end start (fx+ flen 1) 'bytevector-copy!)
+ (##sys#check-range (fx- end start) 0 (fx+ (fx- tlen at) 1) 'bytevector-copy!)
+ (do ((fi start (fx+ fi 1))
+ (ti at (fx+ ti 1)))
+ ((fx= fi end))
+ (bytevector-u8-set! to ti (bytevector-u8-ref from fi)))))))
+ (case-lambda
+ ((to at from) (copy! to at from 0))
+ ((to at from start) (copy! to at from start))
+ ((to at from start end) (copy! to at from start end)))))
+
+(define (bytevector-append . bvs)
+ (##sys#for-each (cut ##sys#check-structure <> 'u8vector 'bytevector-append) bvs)
+ (let* ((lens (map bytevector-length bvs))
+ (bv (make-bytevector (foldl fx+ 0 lens))))
+ (do ((bvs bvs (cdr bvs))
+ (lens lens (cdr lens))
+ (i 0 (fx+ i (car lens))))
+ ((null? bvs) bv)
+ (bytevector-copy! bv i (car bvs) 0 (car lens)))))
+
+;;
+;; XXX TODO There's nothing "utf8" about these at the moment! They
+;; should check their strings ("It is an error for bytevector to contain
+;; invalid UTF-8 byte sequences.").
+;;
+
+(define utf8->string
+ (let ((bv->s (lambda (bv start . end)
+ (##sys#check-structure bv 'u8vector 'utf8->string)
+ (let* ((len (bytevector-length bv))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'utf8->string)
+ (##sys#check-range end start (fx+ len 1) 'utf8->string)
+ (let ((s (##sys#make-string (fx- end start))))
+ (do ((si 0 (fx+ si 1))
+ (vi start (fx+ vi 1)))
+ ((fx= si end) s)
+ (##sys#setbyte s si (bytevector-u8-ref bv vi))))))))
+ (case-lambda
+ ((bv) (bv->s bv 0))
+ ((bv start) (bv->s bv start))
+ ((bv start end) (bv->s bv start end)))))
+
+(define string->utf8
+ (let ((s->bv (lambda (s start . end)
+ (##sys#check-string s 'string->utf8)
+ (let* ((len (##sys#size s))
+ (end (optional end len)))
+ (##sys#check-range start 0 (fx+ end 1) 'string->utf8)
+ (##sys#check-range end start (fx+ len 1) 'string->utf8)
+ (let ((bv (make-bytevector (fx- end start))))
+ (do ((vi 0 (fx+ vi 1))
+ (si start (fx+ si 1)))
+ ((fx= vi end) bv)
+ (bytevector-u8-set! bv vi (##sys#byte s si))))))))
+ (case-lambda
+ ((s) (s->bv s 0))
+ ((s start) (s->bv s start))
+ ((s start end) (s->bv s start end)))))
-(: bytevector-append (#!rest bytevector -> bytevector))
+;;;
+;;; 6.10. Control features
+;;;
-(define (bytevector-append . vs)
- (for-each (cut ##sys#check-structure <> 'u8vector 'bytevector-append) vs)
- (let* ((ls (map bytevector-length vs))
- (ov (make-bytevector (foldl fx+ 0 ls))))
- (let lp ((i 0)
- (vs vs)
- (ls ls))
- (cond ((null? vs) ov)
- (else
- (bytevector-copy! ov i (car vs) 0 (car ls))
- (lp (fx+ i (car ls))
- (cdr vs)
- (cdr ls)))))))
+(: string-for-each ((char -> *) string #!rest string -> void))
+(: string-map ((char -> char) string #!rest string -> string))
+(: vector-for-each ((* -> *) vector #!rest vector -> void))
+(: vector-map ((* -> *) vector #!rest vector -> vector))
+
+(define string-map
+ (case-lambda
+ ((proc str)
+ (%string-map proc str))
+ ((proc . strs)
+ (##sys#check-closure proc 'string-map)
+ (##sys#for-each (cut ##sys#check-string <> 'string-map) strs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size strs)))
+ (str (##sys#make-string len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) str)
+ (string-set! str i (apply proc (map (cut string-ref <> i) strs))))))))
+
+(define string-for-each
+ (case-lambda
+ ((proc str)
+ (%string-for-each proc str))
+ ((proc . strs)
+ (##sys#check-closure proc 'string-for-each)
+ (##sys#for-each (cut ##sys#check-string <> 'string-for-each) strs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size strs)))
+ (str (##sys#make-string len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) str)
+ (apply proc (map (cut string-ref <> i) strs)))))))
+
+(define vector-map
+ (case-lambda
+ ((proc v)
+ (##sys#check-closure proc 'vector-map)
+ (##sys#check-vector v 'vector-map)
+ (let* ((len (##sys#size v))
+ (vec (##sys#make-vector len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) vec)
+ (##sys#setslot vec i (proc (##sys#slot v i))))))
+ ((proc . vs)
+ (##sys#check-closure proc 'vector-map)
+ (##sys#for-each (cut ##sys#check-vector <> 'vector-map) vs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))
+ (vec (##sys#make-vector len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) vec)
+ (##sys#setslot vec i (apply proc (map (cut vector-ref <> i) vs))))))))
+
+(define vector-for-each
+ (case-lambda
+ ((proc v)
+ (##sys#check-closure proc 'vector-for-each)
+ (##sys#check-vector v 'vector-for-each)
+ (let ((len (##sys#size v)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (proc (##sys#slot v i)))))
+ ((proc . vs)
+ (##sys#check-closure proc 'vector-for-each)
+ (##sys#for-each (cut ##sys#check-vector <> 'vector-for-each) vs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))
+ (vec (##sys#make-vector len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) vec)
+ (apply proc (map (cut vector-ref <> i) vs)))))))
;;;
;;; 6.11. Exceptions
@@ -338,29 +598,31 @@
(: raise (* -> noreturn))
(: raise-continuable (* -> . *))
+(define with-exception-handler)
+(define raise)
+(define raise-continuable)
+
;; XXX TODO: This is not threadsafe!
-(define-values (with-exception-handler raise raise-continuable)
- (let ((exception-handlers
- (let ((lst (list ##sys#current-exception-handler)))
- (set-cdr! lst lst)
- lst)))
- (values
- ;; with-exception-handler
- (lambda (handler thunk)
- (dynamic-wind
- (lambda ()
- ;; We might be interoperating with srfi-12 handlers set by intermediate
- ;; non-R7RS code, so check if a new handler was set in the meanwhile.
- (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
- (set! exception-handlers
- (cons ##sys#current-exception-handler exception-handlers)))
- (set! exception-handlers (cons handler exception-handlers))
- (set! ##sys#current-exception-handler handler))
- thunk
- (lambda ()
- (set! exception-handlers (cdr exception-handlers))
- (set! ##sys#current-exception-handler (car exception-handlers)))))
- ;; raise
+(let ((exception-handlers
+ (let ((lst (list ##sys#current-exception-handler)))
+ (set-cdr! lst lst)
+ lst)))
+ (set! with-exception-handler
+ (lambda (handler thunk)
+ (dynamic-wind
+ (lambda ()
+ ;; We might be interoperating with srfi-12 handlers set by intermediate
+ ;; non-R7RS code, so check if a new handler was set in the meanwhile.
+ (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
+ (set! exception-handlers
+ (cons ##sys#current-exception-handler exception-handlers)))
+ (set! exception-handlers (cons handler exception-handlers))
+ (set! ##sys#current-exception-handler handler))
+ thunk
+ (lambda ()
+ (set! exception-handlers (cdr exception-handlers))
+ (set! ##sys#current-exception-handler (car exception-handlers))))))
+ (set! raise
(lambda (obj)
(with-exception-handler
(cadr exception-handlers)
@@ -371,13 +633,13 @@
'exn
'message "exception handler returned"
'arguments '()
- 'location #f)))))
- ;; raise-continuable
+ 'location #f))))))
+ (set! raise-continuable
(lambda (obj)
(with-exception-handler
(cadr exception-handlers)
(lambda ()
- ((cadr exception-handlers) obj)))))))
+ ((cadr exception-handlers) obj))))))
(: error-object? (* --> boolean : (struct condition)))
(: error-object-message ((struct condition) -> string))
@@ -390,32 +652,47 @@
(: read-error? (* --> boolean))
(: file-error? (* --> boolean))
-(define-values (read-error? file-error?)
- (let ((exn? (condition-predicate 'exn))
- (i/o? (condition-predicate 'i/o))
- (file? (condition-predicate 'file))
- (syntax? (condition-predicate 'syntax)))
- (values
- ;; read-error?
- (lambda (obj)
- (and (exn? obj)
- (or (i/o? obj) ; XXX Not fine-grained enough.
- (syntax? obj))))
- ;; file-error?
- (lambda (obj)
- (and (exn? obj)
- (file? obj))))))
-
+(define read-error?)
+(define file-error?)
+
+(let ((exn? (condition-predicate 'exn))
+ (i/o? (condition-predicate 'i/o))
+ (file? (condition-predicate 'file))
+ (syntax? (condition-predicate 'syntax)))
+ (set! read-error?
+ (lambda (obj)
+ (and (exn? obj)
+ (or (i/o? obj) ; XXX Not fine-grained enough.
+ (syntax? obj)))))
+ (set! file-error?
+ (lambda (obj)
+ (and (exn? obj)
+ (file? obj)))))
;;;
;;; 6.13. Input and Output
;;;
+(: binary-port? (* --> boolean))
(: call-with-port (port (port -> . *) -> . *))
(: close-port (port -> void))
-(: output-port-open? (output-port -> boolean))
-(: input-port-open? (input-port -> boolean))
(: eof-object (--> eof))
+(: input-port-open? (input-port -> boolean))
+(: output-port-open? (output-port -> boolean))
+(: peek-u8 (#!optional input-port -> fixnum))
+(: read-bytevector (number #!optional input-port -> (or bytevector eof)))
+(: read-bytevector! (bytevector #!optional input-port number number -> fixnum))
+(: read-string (number #!optional input-port -> (or string eof)))
+(: read-u8 (#!optional input-port -> fixnum))
+(: textual-port? (* --> boolean))
+(: u8-ready? (#!optional input-port -> boolean))
+(: write-string (string #!optional input-port fixnum fixnum -> void))
+(: write-u8 (fixnum #!optional output-port -> void))
+
+;; sic, TODO
+
+(define binary-port? port?)
+(define textual-port? port?)
(define (call-with-port port proc)
(receive ret
@@ -440,6 +717,67 @@
(define (eof-object) #!eof)
-(define flush-output-port flush-output)
+(define peek-u8
+ (case-lambda
+ (()
+ (char->integer (peek-char)))
+ ((port)
+ (##sys#check-input-port port #t 'peek-u8)
+ (char->integer (peek-char port)))))
+
+(define read-string
+ (let ((read-string/eof (lambda (k port)
+ (##sys#check-input-port port #t 'read-string)
+ (if (eof-object? (peek-char port))
+ #!eof
+ (%read-string k port)))))
+ (case-lambda
+ ((k)
+ (read-string/eof k ##sys#standard-input))
+ ((k port)
+ (read-string/eof k port)))))
+
+(define write-string
+ (case-lambda
+ ((s)
+ (%write-string s #f ##sys#standard-output))
+ ((s port)
+ (%write-string s #f port))
+ ((s port start)
+ (##sys#check-string s 'write-string)
+ (let ((len (##sys#size s)))
+ (##sys#check-range start 0 (fx+ len 1) 'write-string)
+ (%write-string (##sys#substring s start len) #f port)))
+ ((s port start end)
+ (##sys#check-string s 'write-string)
+ (##sys#check-range start 0 (fx+ end 1) 'write-string)
+ (##sys#check-range end start (fx+ (##sys#size s) 1) 'write-string)
+ (%write-string (##sys#substring s start end) #f port))))
+
+(define read-bytevector
+ (let ((read-u8vector/eof
+ (lambda (k port)
+ (let ((bv (read-u8vector k port)))
+ (if (fx= 0 (bytevector-length bv)) #!eof bv)))))
+ (case-lambda
+ ((k)
+ (read-u8vector/eof k ##sys#standard-input))
+ ((k port)
+ (read-u8vector/eof k port)))))
+
+(define read-bytevector!
+ (let ((read-u8vector!/eof
+ (lambda (k bv . args)
+ (let ((r (apply read-u8vector! k bv args)))
+ (if (fx= r 0) #!eof r)))))
+ (case-lambda
+ ((bv)
+ (read-u8vector!/eof #f bv))
+ ((bv port)
+ (read-u8vector!/eof #f bv port))
+ ((bv port start)
+ (read-u8vector!/eof #f bv port start))
+ ((bv port start end)
+ (read-u8vector!/eof (fx- end start) bv port start)))))
)
diff --git a/scheme.file.scm b/scheme.file.scm
index 7e783cc..c83f4d3 100644
--- a/scheme.file.scm
+++ b/scheme.file.scm
@@ -2,14 +2,15 @@
call-with-output-file
call-with-input-file
delete-file
- ; TODO open-binary-input-file
+ open-binary-input-file
open-input-file
with-input-from-file
call-with-output-file
file-exists?
- ; TODO open-binary-output-file
+ open-binary-output-file
open-output-file
with-output-to-file)
+
(import scheme)
(import (rename (only chicken delete-file file-exists? :)
(file-exists? chicken-file-exists?)))
@@ -22,4 +23,10 @@
(define (file-exists? filename)
(and (chicken-file-exists? filename) #t))
+ (: open-binary-input-file (string -> input-port))
+ (: open-binary-output-file (string -> output-port))
+
+ (define (open-binary-input-file path) (open-input-file path #:binary))
+ (define (open-binary-output-file path) (open-output-file path #:binary))
+
)
diff --git a/scheme.lazy.scm b/scheme.lazy.scm
new file mode 100644
index 0000000..362e3e4
--- /dev/null
+++ b/scheme.lazy.scm
@@ -0,0 +1,6 @@
+(module scheme.lazy (delay
+ delay-force
+ force
+ make-promise
+ promise?)
+ (import scheme chicken))
diff --git a/scheme.load.scm b/scheme.load.scm
index c15a856..f664f86 100644
--- a/scheme.load.scm
+++ b/scheme.load.scm
@@ -1,3 +1,14 @@
(module scheme.load (load)
+ (import chicken)
+ (import (rename scheme (load %load)
+ (eval %eval)))
- (import scheme))
+ (: load (string #!optional (struct environment) -> undefined))
+
+ (define load
+ (case-lambda
+ ((filename)
+ (%load filename))
+ ((filename environment)
+ (%load filename (lambda (exp)
+ (%eval exp environment)))))))
diff --git a/scheme.process-context.scm b/scheme.process-context.scm
index 169db2b..22dabe2 100644
--- a/scheme.process-context.scm
+++ b/scheme.process-context.scm
@@ -1,10 +1,8 @@
(module scheme.process-context (command-line
- exit
emergency-exit
- ;;XXX
- ;get-environment-variable
- ;get-environment-variables
- )
+ exit
+ get-environment-variable
+ get-environment-variables)
(import scheme
(rename chicken (exit chicken:exit))
@@ -15,13 +13,41 @@
;;;
(: command-line (-> (list-of string)))
-(: exit (* -> noreturn))
-(: emergency-exit (* -> noreturn))
+(: get-environment-variables (-> (list-of (pair string string))))
+(: exit (#!optional * -> noreturn))
+(: emergency-exit (#!optional * -> noreturn))
(define (command-line)
;; Don't cache these; they may be parameterized at any time!
(cons (program-name) (command-line-arguments)))
+;; XXX get-environment-variables copied from posixunix.scm.
+;; (And not actually expected to work on other platforms yet.)
+
+#>
+#ifdef __APPLE__
+# include <crt_externs.h>
+# define C_getenventry(i) ((*_NSGetEnviron())[ i ])
+#else
+extern char **environ;
+# define C_getenventry(i) (environ[ i ])
+#endif
+<#
+
+(define get-environment-variables
+ (let ([get (foreign-lambda c-string "C_getenventry" int)])
+ (lambda ()
+ (let loop ([i 0])
+ (let ([entry (get i)])
+ (if entry
+ (let scan ([j 0])
+ (if (char=? #\= (##core#inline "C_subchar" entry j))
+ (cons (cons (##sys#substring entry 0 j)
+ (##sys#substring entry (fx+ j 1) (##sys#size entry)))
+ (loop (fx+ i 1)))
+ (scan (fx+ j 1)) ) )
+ '()))))))
+
(define (->exit-status obj)
(cond ((integer? obj) obj)
((eq? obj #f) 1)
diff --git a/scheme.repl.scm b/scheme.repl.scm
new file mode 100644
index 0000000..fd95054
--- /dev/null
+++ b/scheme.repl.scm
@@ -0,0 +1,2 @@
+(module scheme.repl (interaction-environment)
+ (import scheme))
diff --git a/scheme.time.scm b/scheme.time.scm
new file mode 100644
index 0000000..3951771
--- /dev/null
+++ b/scheme.time.scm
@@ -0,0 +1,8 @@
+(module scheme.time (current-second
+ current-jiffy
+ jiffies-per-second)
+ (import scheme)
+ (import (rename chicken (current-seconds current-second)))
+ ;; sic, XXX, TODO, etc.
+ (define current-jiffy current-second)
+ (define (jiffies-per-second) 1))
diff --git a/tests/include-ci.scm b/tests/include-ci.scm
new file mode 100644
index 0000000..9fa9c33
--- /dev/null
+++ b/tests/include-ci.scm
@@ -0,0 +1 @@
+(DISPLAY "abc")
diff --git a/tests/include.scm b/tests/include.scm
new file mode 100644
index 0000000..217e174
--- /dev/null
+++ b/tests/include.scm
@@ -0,0 +1 @@
+(display "abc")
diff --git a/tests/run.scm b/tests/run.scm
index 1032672..3749247 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -10,7 +10,6 @@
(ports)
(scheme base)
(scheme char)
- (scheme eval)
(scheme file)
(scheme read)
(scheme write))
@@ -20,6 +19,25 @@
(test-begin "r7rs tests")
+(test-group "4.1.7: Inclusion"
+ (test-group "include"
+ (test "multiple filenames"
+ "abcabc"
+ (with-output-to-string
+ (lambda () (include "include.scm" "include.scm"))))
+ (test-error "case sensitivity"
+ (with-output-to-string
+ (lambda () (include "include-ci.scm")))))
+ (test-group "include-ci"
+ (test "multiple filenames"
+ "abcabc"
+ (with-output-to-string
+ (lambda () (include-ci "include.scm" "include.scm"))))
+ (test "case sensitivity"
+ "abc"
+ (with-output-to-string
+ (lambda () (include-ci "include-ci.scm"))))))
+
(test-group "6.2.6: numerical operations"
(test-group "floor/...truncate-remainder"
(test '(2 1) (receive (floor/ 5 2)))
@@ -75,7 +93,12 @@
(test 1 (remainder 13 -4))
(test -1 (modulo -13 -4))
(test -1 (remainder -13 -4))
- (test -1.0 (remainder -13 -4.0))))
+ (test -1.0 (remainder -13 -4.0)))
+
+ (test-group "square"
+ (test 1 (square 1))
+ (test 16 (square 4))
+ (test 16.0 (square 4.0))))
(test-group "6.3: booleans"
;; How silly...
@@ -309,6 +332,24 @@
(test '((3 8 2 8)) (list b))
(test '((1 8 2 8)) (list a))))
+(test-group "6.5: Symbols"
+ (test-group "symbol=?"
+ (test-error (symbol=?))
+ (test-error (symbol=? 'a))
+ (test-error (symbol=? 'a 1))
+ (test-error (symbol=? 'a 'b 1))
+ (test #t (symbol=? '|| '||))
+ (test #t (symbol=? '|a b| '|a b|))
+ (test #t (symbol=? 'a 'a))
+ (test #f (symbol=? 'a 'b))
+ (test #t (symbol=? 'a 'a 'a))
+ (test #f (symbol=? 'a 'a 'b))
+ (test #f (symbol=? 'a 'b 'b))
+ (test #t (symbol=? 'a 'a 'a 'a))
+ (test #f (symbol=? 'a 'a 'a 'b))
+ (test #f (symbol=? 'a 'a 'b 'b))
+ (test #f (symbol=? 'a 'b 'b 'b))))
+
(test-group "6.6: characters"
(test-group "char*?"
(test-error "arity" (char=? #\a))
@@ -334,6 +375,7 @@
(test #f (char>=? #\b #\a #\b))))
(test-group "6.7: strings"
+
(test-group "string*?"
(test-error "arity" (string=? "a"))
(test-error "type check" (string=? "a" "a" 1))
@@ -355,7 +397,87 @@
(test #t (string>? "c" "b" "a"))
(test #f (string>? "c" "b" "b"))
(test #t (string>=? "b" "b" "a"))
- (test #f (string>=? "b" "a" "b"))))
+ (test #f (string>=? "b" "a" "b")))
+
+ (test-group "string->list"
+ (test-error (string->list "" 1))
+ (test-error (string->list "a" 1 2))
+ (test '(#\a) (string->list "a"))
+ (test '() (string->list "a" 1))
+ (test '(#\b) (string->list "abc" 1 2))
+ (test '() (string->list "abc" 2 2)))
+
+ (test-group "string->vector"
+ (test-error (string->vector "" 1))
+ (test-error (string->vector "a" 0 2))
+ (test #(#\a) (string->vector "a"))
+ (test #() (string->vector "a" 1 1))
+ (test #(#\b) (string->vector "abc" 1 2))
+ (test #() (string->vector "abc" 2 2)))
+
+ (test-group "vector->string"
+ (test-error (vector->string #() 1))
+ (test-error (vector->string #(1)))
+ (test-error (vector->string #(#\a) 0 2))
+ (test "a" (vector->string #(#\a)))
+ (test "" (vector->string #(#\a) 1 1))
+ (test "b" (vector->string #(#\a #\b #\c) 1 2))
+ (test "" (vector->string #(#\a #\b #\c) 2 2))))
+
+(test-group "6.8: vectors"
+
+ (test-group "vector-copy"
+ (test-error (vector-copy ""))
+ (test-error (vector-copy #() #()))
+ (test-error (vector-copy #() 1))
+ (test-error (vector-copy #(0) -1))
+ (test-error (vector-copy #(0) 0 2))
+ (test #() (vector-copy #()))
+ (test #(0 1 2) (vector-copy #(0 1 2)))
+ (test #(1 2) (vector-copy #(0 1 2) 1))
+ (test #(1) (vector-copy #(0 1 2) 1 2))
+ (test #() (vector-copy #(0 1 2) 1 1)))
+
+ (test-group "vector-copy!"
+ (test-error (vector-copy! ""))
+ (test-error (vector-copy! #(0) 0 ""))
+ (test-error (vector-copy! #() #() 0))
+ (test-error (vector-copy! #() 0 #(0)))
+ (test-error (vector-copy! #(0) 1 #(0)))
+ (test-error (vector-copy! #(0) 1 #(0) 0))
+ (test-error (vector-copy! #(0) 0 #(0) 0 2))
+ (test-error (vector-copy! #(0) 0 #(0 1) 1 0))
+ (test-assert (vector-copy! #() 0 #()))
+ (let ((t #(0 1 2))
+ (f #(3 4 5 6)))
+ (vector-copy! t 0 f 1 1)
+ (test "(vector-copy! t 1 f 1 1)" #(0 1 2) t)
+ (vector-copy! t 0 f 0 1)
+ (test "(vector-copy! t 0 f 0 1)" #(3 1 2) t)
+ (vector-copy! t 0 f 1 3)
+ (test "(vector-copy! t 0 f 1 3)" #(4 5 2) t)
+ (vector-copy! t 1 f 2)
+ (test "(vector-copy! t 1 f 1)" #(4 5 6) t)
+ (vector-copy! t 0 f 1)
+ (test "(vector-copy! t 0 f)" #(4 5 6) t)))
+
+ (test-group "vector-append"
+ (test-error (vector-append ""))
+ (test-error (vector-append #() 1))
+ (test #() (vector-append))
+ (test #(0) (vector-append #(0)))
+ (test #() (vector-append #() #()))
+ (test #(0 1) (vector-append #(0) #(1)))
+ (test #(0 1 2 3 4 5) (vector-append #(0 1) #(2 3) #(4 5))))
+
+ (test-group "vector->list"
+ (test-error (vector->list ""))
+ (test-error (vector->list #() 1))
+ (test '() (vector->list #()))
+ (test '(0 1 2) (vector->list #(0 1 2)))
+ (test '(1 2) (vector->list #(0 1 2) 1))
+ (test '(1) (vector->list #(0 1 2) 1 2))
+ (test '() (vector->list #(0 1 2) 2 2))))
(test-group "6.9: bytevectors"
@@ -402,6 +524,75 @@
(test #u8(0 1) (bytevector-append #u8(0) #u8(1)))
(test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5)))))
+(test-group "6.10: Control features"
+
+ (define (1st . a) (first a))
+ (define (2nd . a) (second a))
+ (define (acc proc f . rest) ; accumulate results of `f`
+ (let ((a '()))
+ (apply proc (lambda args (set! a (cons (apply f args) a))) rest)
+ (reverse a)))
+
+ (define char-add1
+ (compose integer->char add1 char->integer))
+
+ (test-group "string-map"
+ (test-error (string-map "abc"))
+ (test-error (string-map values))
+ (test-error (string-map values '(1 2 3)))
+ (test-error (string-map (constantly 1) "abc"))
+ (test "" (string-map values ""))
+ (test "abc" (string-map values "abc"))
+ (test "aaa" (string-map (constantly #\a) "abc"))
+ (test "bcd" (string-map char-add1 "abc"))
+ (test "abc" (string-map 1st "abc" "123"))
+ (test "123" (string-map 2nd "abc" "123"))
+ (test "abc" (string-map 1st "abc" "123456"))
+ (test "123" (string-map 2nd "abc" "123456")))
+
+ (test-group "string-for-each"
+ (test-error (string-for-each "abc"))
+ (test-error (string-for-each values))
+ (test-error (string-for-each values '(1 2 3)))
+ (test '() (acc string-for-each values ""))
+ (test '(#\a #\b #\c) (acc string-for-each values "abc"))
+ (test '(#\b #\c #\d) (acc string-for-each char-add1 "abc"))
+ (test '((#\a #\1) (#\b #\2) (#\c #\3)) (acc string-for-each list "abc" "123"))
+ (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123"))
+ (test '(#\a #\b #\c) (acc string-for-each 1st "abc" "123456"))
+ (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123456")))
+
+ (test-group "vector-map"
+ (test-error (vector-map #(1 2 3)))
+ (test-error (vector-map values))
+ (test-error (vector-map values '(1 2 3)))
+ (test #() (vector-map values #()))
+ (test #(1 2 3) (vector-map values #(1 2 3)))
+ (test #(1 1 1) (vector-map (constantly 1) #(1 2 3)))
+ (test #(2 3 4) (vector-map add1 #(1 2 3)))
+ (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6)))
+ (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6)))
+ (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6 7 8 9)))
+ (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6 7 8 9))))
+
+ (test-group "vector-for-each"
+ (test-error (vector-for-each #(1 2 3)))
+ (test-error (vector-for-each values))
+ (test-error (vector-for-each values '(1 2 3)))
+ (test '() (acc vector-for-each values #()))
+ (test '(1 2 3) (acc vector-for-each values #(1 2 3)))
+ (test '(2 3 4) (acc vector-for-each add1 #(1 2 3)))
+ (test '((1 4) (2 5) (3 6)) (acc vector-for-each list #(1 2 3) #(4 5 6)))
+ (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6)))
+ (test '(1 2 3) (acc vector-for-each 1st #(1 2 3) #(4 5 6 7 8 9)))
+ (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6 7 8 9)))))
+
+(test-group "6.13: Input"
+ (test-assert "read-string returns eof-object for empty string"
+ (eof-object? (with-input-from-string "" (lambda () (read-string 1)))))
+ (test-assert "read-bytevector returns eof-object for empty string"
+ (eof-object? (with-input-from-string "" (lambda () (read-bytevector 1))))))
+
(define-syntax catch
(syntax-rules ()
((_ . body) (handle-exceptions e e . body))))
Trap