~ chicken-r7rs (master) 31bff9ee5f21ff15cb0bcf270eddf405a1efcbdb
commit 31bff9ee5f21ff15cb0bcf270eddf405a1efcbdb
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Mon May 30 09:46:46 2016 +1200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon May 30 09:46:46 2016 +1200
Many import updates and fixes after chicken-5 changes
diff --git a/scheme.base.scm b/scheme.base.scm
index 6e587f0..a8e4d8a 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,29 +1,28 @@
(module scheme.base ()
-(import (rename (except chicken modulo quotient remainder
- vector-copy!
- with-exception-handler)
+(import (rename (except (chicken) vector-copy! with-exception-handler)
(features feature-keywords)))
-(import (except scheme syntax-rules cond-expand
- assoc list-set! list-tail member
- char=? char<? char>? char<=? char>=?
- string=? string<? string>? string<=? string>=?
- string-copy string->list vector->list vector-fill!))
+(import (except (scheme) syntax-rules cond-expand assoc list-tail member
+ char=? char<? char>? char<=? char>=? string=? string<?
+ string>? string<=? string>=? string-copy string->list
+ vector->list vector-fill!))
-(import (prefix (only scheme char=? char<? char>? char<=? char>=?
- string=? string<? string>? string<=? string>=?)
+(import (prefix (only (scheme) char=? char<? char>? char<=? char>=?
+ string=? string<? string>? string<=? string>=?)
%))
-(import (rename (only srfi-4 make-u8vector subu8vector u8vector u8vector?
- u8vector-length u8vector-ref u8vector-set!
- read-u8vector read-u8vector! write-u8vector)
+(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? bytevector?)
(make-u8vector make-bytevector)
+ (read-u8vector read-bytevector)
(write-u8vector write-bytevector)))
(include "scheme.base-interface.scm")
@@ -46,9 +45,8 @@
(quotient&remainder truncate/)))
;; 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)
+(import (prefix (only (chicken io) write-string) %))
+(import (rename (only (chicken io) read-line read-string read-byte write-byte)
(read-byte read-u8)
(write-byte write-u8)))
@@ -61,9 +59,8 @@
(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))
+(import (prefix (only (srfi 13) string-for-each string-map) %))
+(import (only (srfi 13) string-copy string-copy! string-fill! string->list))
;; For d-r-t redefinition.
(import-for-syntax (only chicken define-record-type))
@@ -720,9 +717,7 @@
(: 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 : port?))
(: u8-ready? (#!optional input-port -> boolean))
@@ -770,19 +765,6 @@
(if (eof-object? c) c
(char->integer c))))))
-(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
- (##sys#read-string/port 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)
@@ -800,17 +782,6 @@
(##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 port . args)
diff --git a/scheme.read.scm b/scheme.read.scm
index 8ca0b13..d9f5afc 100644
--- a/scheme.read.scm
+++ b/scheme.read.scm
@@ -1,7 +1,9 @@
-(module scheme.read (read)
- (import (except scheme read)
- (only chicken : current-read-table feature? fluid-let fx+ fx= optional unless when)
- (only chicken case-sensitive define-constant define-inline parameterize))
+(module (scheme read) (read)
+ (import (except (scheme) read)
+ (only (chicken) : case-sensitive current-read-table feature?)
+ (only (chicken) fluid-let fx+ fx= optional unless when)
+ (only (chicken) define-constant define-inline parameterize)
+ (only (chicken read-syntax) set-read-syntax!))
;;;
;;; 2.1 Identifiers
@@ -15,13 +17,13 @@
(define-inline (port-fold-case p)
(##sys#slot p port-fold-case-slot))
- (##sys#set-read-mark!
+ (set-read-syntax!
'fold-case
(lambda (p)
(##sys#setslot p port-fold-case-slot 'fold-case)
(read p)))
- (##sys#set-read-mark!
+ (set-read-syntax!
'no-fold-case
(lambda (p)
(##sys#setslot p port-fold-case-slot 'no-fold-case)
diff --git a/scheme.time.scm b/scheme.time.scm
index 43ae33d..9f9524f 100644
--- a/scheme.time.scm
+++ b/scheme.time.scm
@@ -1,14 +1,15 @@
(module scheme.time (current-second
current-jiffy
jiffies-per-second)
- (import (only scheme define inexact->exact)
- (only chicken : define-constant current-seconds current-milliseconds fp+))
+ (import (only (chicken) : define-constant)
+ (only (chicken time) current-seconds current-milliseconds)
+ (only (scheme) + define inexact->exact))
;; As of 2012-06-30.
(define-constant tai-offset 35.)
(: current-second (--> float))
- (define (current-second) (fp+ (current-seconds) tai-offset))
+ (define (current-second) (+ (current-seconds) tai-offset))
(: current-jiffy (--> fixnum))
(define (current-jiffy) (inexact->exact (current-milliseconds)))
diff --git a/tests/run.scm b/tests/run.scm
index 91696b2..d8b10b9 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,13 +1,9 @@
-(use r7rs)
-
-;; XXX: This seems to be necessary in order to get the syntax-rules
-;; from r7rs rather than the built-in CHICKEN one. I'm not sure if
-;; that's correct or not...
-(import-for-syntax (r7rs))
-
-(import (chicken)
+(import (r7rs)
+ (chicken)
+ (chicken data-structures)
+ (chicken io)
+ (chicken ports)
(test)
- (ports)
(scheme base)
(scheme char)
(scheme eval)
@@ -15,6 +11,11 @@
(scheme read)
(scheme write))
+;; XXX: This seems to be necessary in order to get the syntax-rules
+;; from r7rs rather than the built-in CHICKEN one. I'm not sure if
+;; that's correct or not...
+(import-for-syntax (r7rs))
+
(define (read-from-string s)
(with-input-from-string s read))
@@ -25,12 +26,12 @@
'(FOO mooh qux blah foo BAR)
(append
(with-input-from-string
- "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-file)))
+ "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-all)))
(test "#!(no-)fold-case only affects subsequent reads from the same port"
'(FOO bar baz downcased UPCASED)
(append
- (with-input-from-string "FOO #!fold-case bar BAZ" read-file)
- (with-input-from-string "downcased UPCASED" read-file))))
+ (with-input-from-string "FOO #!fold-case bar BAZ" read-all)
+ (with-input-from-string "downcased UPCASED" read-all))))
(test-group "4.1.7: Inclusion"
(test-group "include"
Trap