~ chicken-r7rs (master) 8e32b4ab01f198384579c4301115f820a942228a
commit 8e32b4ab01f198384579c4301115f820a942228a
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Jan 7 01:54:45 2014 +0000
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Jan 7 01:54:45 2014 +0000
import/library loading, scheme.eval, scheme.r5rs, a bunch of other hacking
diff --git a/r7rs-compile-time-module.scm b/r7rs-compile-time-module.scm
index 172a7f9..0ff9be8 100644
--- a/r7rs-compile-time-module.scm
+++ b/r7rs-compile-time-module.scm
@@ -1,9 +1,10 @@
(module r7rs-compile-time (parse-library-definition
+ define-extended-arity-comparator
process-cond-expand
fixup-import/export-spec
parse-library-name
+ import-transformer
read-forms
- current-source-filename
register-r7rs-module
locate-library)
diff --git a/r7rs-compile-time.scm b/r7rs-compile-time.scm
index 12543d3..5a74cfa 100644
--- a/r7rs-compile-time.scm
+++ b/r7rs-compile-time.scm
@@ -68,15 +68,41 @@
((? symbol? spec) spec)
(_ (syntax-error loc "invalid import/export specifier" spec))))
-(define (current-source-filename)
- (or (and (feature? #:compiling) ##compiler#source-filename)
- ##sys#current-source-filename))
+;; Dig e.g. foo.bar out of (only (foo bar) ...) ...
+(define (import/export-spec-feature-name spec loc)
+ (match spec
+ ((? symbol? spec) spec)
+ (((or 'only 'except 'rename 'prefix) name . more)
+ (import/export-spec-feature-name name loc))
+ ((name ...)
+ (parse-library-name name loc))
+ (else
+ (syntax-error loc "invalid import/export specifier" spec))))
+
+(define (import-transformer type)
+ (er-macro-transformer
+ (let ((%import (caddr (assq type (##sys#macro-environment))))) ; XXX safe?
+ (lambda (x r c)
+ `(##core#begin
+ ,@(map (lambda (spec)
+ (let ((spec (fixup-import/export-spec spec type))
+ (name (import/export-spec-feature-name spec type)))
+ (%import (list type spec) '() (##sys#current-environment))
+ (if (memq name '(scheme foreign)) ; XXX others?
+ '(##core#undefined)
+ `(##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-filename) filename))
+ (make-pathname (current-source-directory) filename))
(lambda (port)
(parameterize ((case-sensitive ci?))
(read port)))))
@@ -98,10 +124,8 @@
specs))
(define (parse-imports specs)
;; What R7RS calls IMPORT, we call USE (it imports *and* loads code)
- ;; XXX TODO: Should be import-for-syntax'ed as well?
- `(##core#require-extension
- ,(map (lambda (s) (fixup-import/export-spec s 'import)) specs)
- #t))
+ ;; XXX TODO: Should be import-for-syntax'ed as well?
+ `(import ,@specs)) ; NOTE this is the r7rs module's IMPORT!
(define (process-includes fnames ci?)
`(##core#begin
,@(map (match-lambda
@@ -136,7 +160,7 @@
,(parse-decls more)))
((('cond-expand decls ...) . more)
`(##core#begin
- ,(parse-decls (process-cond-expand decls))
+ ,@(process-cond-expand decls)
,(parse-decls more)))
((('begin code ...) . more)
`(##core#begin
@@ -144,15 +168,15 @@
,(parse-decls more)))
(decl (syntax-error 'define-library "invalid library declaration" decl))))
`(##core#begin
- (##core#module
- ,real-name ((,dummy-export))
- ;; gruesome hack: we add a dummy export for adding indirect exports
- (import (rename scheme (define-syntax hidden:define-syntax)))
- (import (only scheme.base import export)) ; overwrites existing "import"
- ;; Another gruesome hack: register feature so "use" works properly
- (import (rename chicken (register-feature! hidden:register-feature!)))
- (hidden:register-feature! (##core#quote ,real-name))
- (hidden:define-syntax ,dummy-export (lambda () #f))
+ (##core#module
+ ,real-name ((,dummy-export))
+ ;; gruesome hack: we add a dummy export for adding indirect exports
+ (##core#define-syntax ,dummy-export (##core#lambda () #f))
+ ;; Another gruesome hack: provide feature so "use" works properly
+ (##sys#provide (##core#quote ,real-name))
+ ;; Set up an R7RS environment for the module's body.
+ (import-for-syntax r7rs) ; overwrites "syntax-rules"
+ (import r7rs) ; overwrites existing "import" and "import-for-syntax"
,(parse-decls decls)))))
(_ (syntax-error 'define-library "invalid library definition" form))))
@@ -173,3 +197,16 @@
(lambda (dummylist)
(set-cdr! dummylist (cons sym (cdr dummylist))))))))
(register-export sym mod))))))
+
+(define-syntax define-extended-arity-comparator
+ (syntax-rules ()
+ ((_ name comparator check-type)
+ (define name
+ (let ((c comparator))
+ (lambda (o1 o2 . os)
+ (check-type o1 'name)
+ (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
+ (check-type o2 'name)
+ (if (null? os)
+ (and eq (c o1 o2))
+ (lp o2 (car os) (cdr os) (and eq (c o1 o2)))))))))))
diff --git a/r7rs.scm b/r7rs.scm
index b423eec..54c7ac3 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -1,20 +1,38 @@
-(module r7rs (define-library)
+(module r7rs (define-library import import-for-syntax export syntax-rules)
- (import (except scheme syntax-rules)) ;XXX except ...
- (import chicken) ;XXX except ...
- (import numbers)
- (import scheme.base)
- (include "scheme.base-interface.scm")
+ (import (except scheme syntax-rules)) ;XXX except ...
+ (import (only chicken include)) ;XXX except ...
- (begin-for-syntax
- (require-library r7rs-compile-time numbers))
+ ;; For syntax definition helpers.
(import-for-syntax r7rs-compile-time matchable)
+ (begin-for-syntax (require-library r7rs-compile-time))
-(require-library scheme.base)
+ ;; For extended number literals.
+ (require-library numbers)
+
+ ;; For #u8(...) syntax.
+ (require-extension srfi-4)
(let ((old-hook ##sys#user-read-hook))
+ ;; XXX Read syntax for "#false" and srfi-4's "#f32(...)" and friends
+ ;; don't play nicely together, so we have to copy some of srfi-4.scm's
+ ;; read hook here, to fall back on when we hit a vector of floats.
+ (define read-srfi-4-vector
+ (let ([consers (list 'u8 list->u8vector
+ 's8 list->s8vector
+ 'u16 list->u16vector
+ 's16 list->s16vector
+ 'u32 list->u32vector
+ 's32 list->s32vector
+ 'f32 list->f32vector
+ 'f64 list->f64vector)])
+ (lambda (tag port)
+ (let* ([x (read port)])
+ (cond [(or (eq? tag 'f) (eq? tag 'F)) #f]
+ [(memq tag consers) => (lambda (c) ((##sys#slot (##sys#slot c 1) 0) (read port)))]
+ [else (##sys#read-error port "illegal bytevector syntax" tag)])))))
(set! ##sys#user-read-hook
- (lambda (char port)
+ (lambda (char port)
(define (fail tok)
(##sys#read-error port "invalid boolean literal syntax" tok))
(case char
@@ -25,9 +43,21 @@
(let ((str (symbol->string sym)))
(cond ((or (string-ci=? "t" str) (string-ci=? "true" str)) #t)
((or (string-ci=? "f" str) (string-ci=? "false" str)) #f)
- (else (fail sym)))))))
+ (else (read-srfi-4-vector sym port)))))))
(else (old-hook char port))))))
+;;;
+;;; 5.2. Import declarations
+;;;
+
+(define-syntax import (import-transformer 'import))
+(define-syntax import-for-syntax (import-transformer 'import-for-syntax))
+
+;;;
+;;; 5.4. Syntax definitions
+;;;
+(include "synrules.scm")
+
;;;
;;; 5.6.1. Libraries
;;;
@@ -39,7 +69,4 @@
((_ name decls ...)
(let ((dummy (register-r7rs-module (parse-library-name name 'define-library))))
(parse-library-definition x dummy)))
- (_ (syntax-error 'define-library "invalid library definition" x))))))
-
-
-)
+ (_ (syntax-error 'define-library "invalid library definition" x)))))))
diff --git a/r7rs.setup b/r7rs.setup
index 59224d0..13c8073 100644
--- a/r7rs.setup
+++ b/r7rs.setup
@@ -4,13 +4,12 @@
(use make srfi-1)
(define scheme-modules
- '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "load" "process-context" "read")) ;XXX
+ '("case-lambda" "char" "complex" "cxr" "eval" "file" "inexact" "load" "process-context" "r5rs" "read" "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)
(compile -s -O3 -d0 r7rs-compile-time.import.scm))
- ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm"
- "synrules.scm")
+ ("scheme.base.so" ("scheme.base.scm" "scheme.base-interface.scm")
(compile -s -O3 -d1 scheme.base.scm -J -emit-type-file scheme.base.types)
(compile -s -O3 -d0 scheme.base.import.scm)))
'("r7rs-compile-time.so" "scheme.base.so"))
@@ -27,7 +26,7 @@
(list so))))
scheme-modules)
-(make (("r7rs.so" ("r7rs.scm" "scheme.base-interface.scm")
+(make (("r7rs.so" ("r7rs.scm" "synrules.scm")
(compile -s -O3 -d0 r7rs.scm -J)
(compile -s -O3 -d0 r7rs.import.scm))))
diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index 83879aa..380047a 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -1,17 +1,13 @@
(export
- #|
* + - /
<= < >= = >
abs
and
- |#
append
- #|
apply
- |#
assoc assq assv
- #|
begin
+ #|
binary-port?
|#
boolean? boolean=?
@@ -22,51 +18,35 @@
bytevector?
car cdr
caar cadr cdar cddr
- #|
call-with-current-continuation call/cc
- |#
call-with-port
- #|
call-with-values
case
ceiling
char-ready?
char->integer integer->char
- |#
char=? char<? char>? char<=? char>=?
- #|
char?
close-input-port close-output-port
- |#
close-port
- #|
complex?
cond
- |#
cond-expand
cons
- #|
current-input-port current-output-port current-error-port
define
- define-record-type
- |#
+ define-record-type ; TODO
define-syntax
- #|
- define-values
+ define-values ; TODO
denominator numerator
do
dynamic-wind
- else
- |#
eof-object
- #|
eof-object?
eq? eqv? equal?
error
- |#
error-object-irritants error-object-message
error-object?
- #|
even? odd?
exact inexact
exact-integer-sqrt
@@ -74,40 +54,34 @@
exact? inexact?
expt
features
- |#
file-error?
- #|
floor
- |#
floor/ floor-quotient floor-remainder
- #|
flush-output-port
for-each
gcd lcm
+ #|
get-output-bytevector
- get-output-string
|#
+ get-output-string
guard
- #|
if
+ #|
+ import ; provided by the "r7rs" module
+ import-for-syntax ; XXX should we? Probably not, it's not in r7rs...
|#
- import
+ include
#|
- ;; import-for-syntax XXX should we? Probably not, it's not in r7rs...
- include include-ci
+ include-ci
|#
input-port-open? output-port-open?
- #|
input-port? output-port?
integer?
lambda
- |#
length
- #|
let let*
letrec letrec*
let-values let*-values
- |#
let-syntax letrec-syntax
#|
library ; for "cond-expand"
@@ -115,107 +89,117 @@
list list-copy list-ref list-set! list-tail list?
make-bytevector
make-list
- #|
make-parameter
make-string
make-vector
map
max min
- |#
member memq memv
- #|
modulo remainder
negative? positive?
newline
- |#
not
null?
- #|
number->string string->number
number?
+ #|
open-input-bytevector open-output-bytevector
- open-input-string open-output-string
|#
+ open-input-string open-output-string
+ or
pair?
- #|
parameterize
peek-char
+ #|
peek-u8
+ |#
port?
procedure?
quasiquote
quote
- |#
quotient remainder
raise raise-continuable
- #|
rational?
rationalize
+ #|
read-bytevector read-bytevector!
- read-char
|#
+ read-char
read-error?
#|
read-line
read-string
read-u8
- real?
|#
+ real?
reverse
- #|
round
set!
- |#
set-car! set-cdr!
- #|
square
string
string->list list->string
+ #|
string->utf8 utf8->string
+ |#
string->symbol symbol->string
+ #|
string->vector
+ |#
string-append
- string-copy string-copy!
+ string-copy
+ #|
+ string-copy!
+ |#
string-fill!
+ #|
string-for-each
+ |#
string-length
+ #|
string-map
- string-ref string-set!
|#
+ string-ref string-set!
string=? string<? string>? string<=? string>=?
- #|
string?
+ #|
substring
symbol=?
+ |#
symbol?
syntax-error
- |#
- syntax-rules
#|
+ syntax-rules
textual-port?
- truncate
|#
+ truncate
truncate/ truncate-quotient truncate-remainder
#|
u8-ready?
+ |#
unless
+ #|
unquote unquote-splicing
+ |#
values
vector
+ #|
vector-append
vector-copy vector-copy!
vector-for-each
vector-length
vector-map
+ |#
vector-ref vector-set!
when
- |#
with-exception-handler
#|
write-bytevector
+ |#
write-char
+ #|
write-string
write-u8
- zero?
|#
+ zero?
)
diff --git a/scheme.base.scm b/scheme.base.scm
index 7020311..ec4e8f0 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,13 +1,14 @@
(module scheme.base ()
-(import (except scheme syntax-rules cond-expand
+(import (except scheme syntax-rules cond-expand include
assoc list-set! list-tail member
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 (except chicken with-exception-handler raise quotient remainder modulo))
+(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!)
@@ -17,28 +18,26 @@
(u8vector-length bytevector-length)
(u8vector-ref bytevector-u8-ref)
(u8vector-set! bytevector-u8-set!)))
-(import numbers)
-
-(include "scheme.base-interface.scm")
-(require-library srfi-4)
+(%include "scheme.base-interface.scm")
(begin-for-syntax (require-library r7rs-compile-time))
(import-for-syntax r7rs-compile-time)
+(import r7rs-compile-time)
+(import numbers)
+;;;
+;;; 4.1.7. Inclusion
+;;;
-(define-syntax import
- (er-macro-transformer
- (lambda (x r c)
- (##sys#expand-import
- (cons (car x)
- (map (lambda (spec)
- (fixup-import/export-spec (strip-syntax spec) 'import))
- (cdr x)))
- r c
- ##sys#current-environment ##sys#macro-environment
- #f #f 'import) ) ) )
-
+(define-syntax include
+ (syntax-rules ()
+ ((_ str)
+ (%include str))
+ ((_ str . rest)
+ (begin
+ (%include str)
+ (include . rest)))))
;;;
;;; 4.2.1. Conditionals
@@ -115,10 +114,12 @@
(apply values args))))))))))))))
;;;
-;;; 5.4. Syntax definitions
+;;; 6.2.6 Numerical operations
;;;
-(include "synrules.scm")
+(: square (number --> number))
+
+(define (square n) (* n n))
;;;
;;; 6.3 Booleans
@@ -243,19 +244,6 @@
;;; 6.6 Characters
;;;
-(define-syntax define-extended-arity-comparator
- (syntax-rules ()
- ((_ name comparator check-type)
- (define name
- (let ((cmp comparator))
- (lambda (o1 o2 . os)
- (check-type o1 'name)
- (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
- (check-type o2 'name)
- (if (null? os)
- (and eq (cmp o1 o2))
- (lp o2 (car os) (cdr os) (and eq (cmp o1 o2)))))))))))
-
(: char=? (char char #!rest char -> boolean))
(: char<? (char char #!rest char -> boolean))
(: char>? (char char #!rest char -> boolean))
@@ -452,4 +440,6 @@
(define (eof-object) #!eof)
+(define flush-output-port flush-output)
+
)
diff --git a/scheme.char.scm b/scheme.char.scm
index 3c1db5d..e66e19d 100644
--- a/scheme.char.scm
+++ b/scheme.char.scm
@@ -12,20 +12,7 @@
%))
(import chicken)
-
-;; Copy-pasta from scheme.base.scm.
-(define-syntax define-extended-arity-comparator
- (syntax-rules ()
- ((_ name comparator check-type)
- (define name
- (let ((c comparator))
- (lambda (o1 o2 . os)
- (check-type o1 'name)
- (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
- (check-type o2 'name)
- (if (null? os)
- (and eq (c o1 o2))
- (lp o2 (car os) (cdr os) (and eq (c o1 o2)))))))))))
+(require-extension r7rs-compile-time)
(: char-ci=? (char char #!rest char -> boolean))
(: char-ci<? (char char #!rest char -> boolean))
diff --git a/scheme.eval.scm b/scheme.eval.scm
index c25b0cc..b96a9d7 100644
--- a/scheme.eval.scm
+++ b/scheme.eval.scm
@@ -1,25 +1,33 @@
(module scheme.eval (eval
environment)
- (import scheme chicken)
- (use r7rs-compile-time)
+ (import (rename scheme (eval %eval)) chicken)
+ (import r7rs-compile-time)
;;;
;;; 6.12. Environments and evaluation
;;;
+ (: eval (* (struct environment) -> *))
+
+ (define (eval expr env) (%eval expr env))
+
(: environment (list -> (struct environment)))
(define (environment . specs)
(let ((name (gensym "environment-module-")))
;; create module...
- (eval `(module ,name ()
- ,@(map (lambda (spec)
- `(import ,(fixup-import/export-spec spec 'environment)))
- specs)))
- (let ((env (module-environment name)))
+ (%eval `(module ,name ()
+ ,@(map (lambda (spec)
+ `(import ,(fixup-import/export-spec spec 'environment)))
+ specs)))
+ (let ((mod (##sys#find-module name)))
;; ...and remove it right away
- (set! ##sys#module-table (##sys#delq (assq name ##sys#module-table) ##sys#module-table))
- env)))
+ (set! ##sys#module-table (##sys#delq mod ##sys#module-table))
+ (##sys#make-structure 'environment
+ name
+ (let ((env (##sys#slot mod 13)))
+ (append (car env) (cdr env))) ; combine env and syntax bindings
+ #t))))
)
diff --git a/scheme.r5rs.scm b/scheme.r5rs.scm
new file mode 100644
index 0000000..d5b8d8b
--- /dev/null
+++ b/scheme.r5rs.scm
@@ -0,0 +1,43 @@
+(module scheme.r5rs ()
+
+ (import chicken)
+ (import
+ (rename scheme
+ (null-environment %null-environment)
+ (scheme-report-environment %scheme-report-environment)))
+
+ (import numbers)
+ (export angle make-polar make-rectangular rationalize)
+
+ (require-extension scheme.eval)
+ (export null-environment scheme-report-environment)
+
+ (reexport
+ (except scheme
+ null-environment scheme-report-environment eval
+ and begin begin-for-syntax case cond cond-expand define
+ define-syntax delay delay-force do else export if lambda let
+ let* let-syntax letrec letrec* letrec-syntax module or
+ quasiquote quote reexport require-extension
+ require-extension-for-syntax require-library set! syntax))
+
+ (define-constant null-environment-identifiers
+ '(and begin case cond cond-expand define define-syntax delay
+ delay-force do if lambda let let* let-syntax letrec letrec*
+ letrec-syntax or quasiquote quote set! syntax-rules))
+
+ (: null-environment (fixnum -> (struct environment)))
+
+ (define (null-environment version)
+ (case version
+ ((7) (environment `(only (scheme base) ,@null-environment-identifiers)))
+ ((5) (environment `(only (scheme r5rs) ,@null-environment-identifiers)))
+ (else (%null-environment version))))
+
+ (: scheme-report-environment (fixnum -> (struct environment)))
+
+ (define (scheme-report-environment version)
+ (case version
+ ((7) (environment '(scheme base)))
+ ((5) (environment '(scheme r5rs)))
+ (else (%scheme-report-environment version)))))
diff --git a/scheme.write.scm b/scheme.write.scm
new file mode 100644
index 0000000..63cd99a
--- /dev/null
+++ b/scheme.write.scm
@@ -0,0 +1,6 @@
+(module scheme.write (display
+ write
+ ; write-shared
+ write-simple)
+ (import scheme)
+ (define write-simple write))
diff --git a/tests/run.scm b/tests/run.scm
index 6149b47..1032672 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,9 +1,19 @@
-(use r7rs test)
+(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-for-syntax (r7rs))
+
+(import (chicken)
+ (test)
+ (ports)
+ (scheme base)
+ (scheme char)
+ (scheme eval)
+ (scheme file)
+ (scheme read)
+ (scheme write))
(define (read-from-string s)
(with-input-from-string s read))
@@ -304,6 +314,8 @@
(test-error "arity" (char=? #\a))
(test-error "type check" (char=? #\a #\a 1))
(test-error "no shortcutting" (char=? #\a #\b 1))
+ (test #f (char? 1))
+ (test #t (char? #\a))
(test #t (char=? #\a #\a))
(test #f (char=? #\a #\b))
(test #t (char=? #\a #\a #\a))
@@ -326,6 +338,8 @@
(test-error "arity" (string=? "a"))
(test-error "type check" (string=? "a" "a" 1))
(test-error "no shortcutting" (string=? "a" "b" 1))
+ (test #f (string? 1))
+ (test #t (string? "a"))
(test #t (string=? "a" "a"))
(test #f (string=? "a" "b"))
(test #t (string=? "a" "a" "a"))
@@ -762,6 +776,12 @@
(test "DSSSL keyword arguments aren't renamed (not R7RS)"
"hello, XXX" (bar who: "XXX")))))
+(test-group "define-library"
+ (test-assert "R7RS libraries use the numbers extension"
+ (define-library (foo)
+ (import (scheme base))
+ (begin (eq? numbers#+ +)))))
+
(test-end "r7rs tests")
(test-exit)
Trap