diff --git a/src/ikarus.boot b/src/ikarus.boot index eab8955..efe3ff4 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.load.ss b/src/ikarus.load.ss index 7da2ce5..854868b 100644 --- a/src/ikarus.load.ss +++ b/src/ikarus.load.ss @@ -1,9 +1,9 @@ (library (ikarus load) - (export load) + (export load load-r6rs-top-level) (import (except (ikarus) load) - (only (ikarus syntax) eval-top-level) + (only (ikarus syntax) eval-top-level eval-r6rs-top-level) (only (ikarus reader) read-initial)) (define load-handler @@ -28,4 +28,22 @@ (unless (eof-object? x) (eval-proc x) (read-and-eval p eval-proc))) - (close-input-port p))]))) + (close-input-port p))])) + (define load-r6rs-top-level + (lambda (x) + (define (read-file) + (let ([p (open-input-file x)]) + (let ([x (read-initial p)]) + (if (eof-object? x) + (begin (close-input-port p) '()) + (cons x + (let f () + (let ([x (read p)]) + (cond + [(eof-object? x) + (close-input-port p) + '()] + [else (cons x (f))])))))))) + (let ([prog (read-file)]) + (eval-r6rs-top-level prog)))) + ) diff --git a/src/ikarus.main.ss b/src/ikarus.main.ss index 438ddfc..498a3a5 100644 --- a/src/ikarus.main.ss +++ b/src/ikarus.main.ss @@ -17,24 +17,39 @@ (library (ikarus interaction) (export) - (import (ikarus) (ikarus greeting)) - (let-values ([(files script args) + (import (ikarus) + (ikarus greeting) + (only (ikarus load) load-r6rs-top-level)) + (let-values ([(files script script-type args) (let f ([args (command-line-arguments)]) (cond - [(null? args) (values '() #f '())] + [(null? args) (values '() #f #f '())] [(string=? (car args) "--") - (values '() #f (cdr args))] + (values '() #f #f (cdr args))] [(string=? (car args) "--script") (let ([d (cdr args)]) (cond - [(null? d) + [(null? d) (error #f "--script requires a script name")] [else - (values '() (car d) (cdr d))]))] + (values '() (car d) 'script (cdr d))]))] + [(string=? (car args) "--r6rs-script") + (let ([d (cdr args)]) + (cond + [(null? d) + (error #f "--r6rs-script requires a script name")] + [else + (values '() (car d) 'r6rs-script (cdr d))]))] [else - (let-values ([(f* script a*) (f (cdr args))]) - (values (cons (car args) f*) script a*))]))]) + (let-values ([(f* script script-type a*) (f (cdr args))]) + (values (cons (car args) f*) script script-type a*))]))]) (cond + [(eq? script-type 'r6rs-script) + (command-line-arguments (cons script args)) + ;(for-each load files) + (load-r6rs-top-level script) + ;(load script) + (exit 0)] [script ; no greeting, no cafe (command-line-arguments (cons script args)) (for-each load files) diff --git a/src/ikarus.syntax.ss b/src/ikarus.syntax.ss index dec4f05..241345f 100644 --- a/src/ikarus.syntax.ss +++ b/src/ikarus.syntax.ss @@ -8,7 +8,7 @@ (library (ikarus syntax) (export identifier? syntax-dispatch generate-temporaries free-identifier=? syntax-error - boot-library-expand eval-top-level) + eval-r6rs-top-level boot-library-expand eval-top-level) (import (ikarus library-manager) (only (ikarus compiler) eval-core) @@ -1675,12 +1675,6 @@ (build-letrec* no-source (reverse lex*) (reverse rhs*) (build-sequence no-source init*))))))) - (define chi-library-internal - (lambda (e* rib) - (let-values ([(e* r mr lex* rhs* mod** _kwd*) - (chi-body* e* '() '() '() '() '() '() rib #t)]) - (values (append (apply append (reverse mod**)) e*) - r mr (reverse lex*) (reverse rhs*))))) (define chi-internal-module (lambda (e r mr lex* rhs* mod** kwd*) (define parse-module @@ -1763,7 +1757,10 @@ [(_ x* ...) (chi-body* (append x* (cdr e*)) r mr lex* rhs* mod** kwd* rib top?)])] - [(global-macro) (error 'chi-body "global macro")] + [(global-macro) + (chi-body* + (cons (add-subst rib (chi-global-macro value e)) (cdr e*)) + r mr lex* rhs* mod** kwd* rib top?)] [(local-macro) (chi-body* (cons (add-subst rib (chi-local-macro value e)) (cdr e*)) @@ -1965,6 +1962,12 @@ (unless (procedure? x) (error 'vis-collector "~s is not a procedure" x)) x))) + (define chi-library-internal + (lambda (e* rib top?) + (let-values ([(e* r mr lex* rhs* mod** _kwd*) + (chi-body* e* '() '() '() '() '() '() rib top?)]) + (values (append (apply append (reverse mod**)) e*) + r mr (reverse lex*) (reverse rhs*))))) (define core-library-expander (lambda (e) (let-values ([(name exp-int* exp-ext* imp* b*) (parse-library e)]) @@ -1976,7 +1979,7 @@ (parameterize ([inv-collector rtc] [vis-collector vtc]) (let-values ([(init* r mr lex* rhs*) - (chi-library-internal b* rib)]) + (chi-library-internal b* rib #f)]) (seal-rib! rib) (let ([rhs* (chi-rhs* rhs* r mr)]) (let ([invoke-body (if (and (null? init*) (null? lex*)) @@ -1994,6 +1997,35 @@ (build-letrec* no-source lex* rhs* invoke-body) macro* export-subst export-env))))))))))))) + + (define (parse-top-level-program e*) + (syntax-match e* () + [((import imp* ...) b* ...) (eq? import 'import) + (values imp* b*)] + [_ (error "invalid syntax of top-level program")])) + + (define top-level-expander + (lambda (e*) + (let-values ([(imp* b*) (parse-top-level-program e*)]) + (let-values ([(subst imp*) (get-import-subst/libs imp*)]) + (let ([rib (make-top-rib subst)]) + (let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)] + [rtc (make-collector)] + [vtc (make-collector)]) + (parameterize ([inv-collector rtc] + [vis-collector vtc]) + (let-values ([(init* r mr lex* rhs*) + (chi-library-internal b* rib #t)]) + (seal-rib! rib) + (let ([rhs* (chi-rhs* rhs* r mr)]) + (let ([invoke-body (if (null? init*) + (build-void) + (build-sequence no-source + (chi-expr* init* r mr)))]) + (unseal-rib! rib) + (values (rtc) + (build-letrec* no-source + lex* rhs* invoke-body)))))))))))) (define (visit! macro*) (for-each (lambda (x) (let ([loc (car x)] [proc (cadr x)]) @@ -2083,6 +2115,12 @@ (apply string-append args) (strip x '())))) (define identifier? (lambda (x) (id? x))) + (define eval-r6rs-top-level + (lambda (x*) + (let-values ([(lib* invoke-code) (top-level-expander x*)]) + (for-each invoke-library lib*) + (eval-core invoke-code) + (void)))) (define eval-top-level (lambda (x) (unless (pair? x) diff --git a/src/tests.libraries.ss b/src/tests.libraries.ss index 91b6322..c470dd9 100644 --- a/src/tests.libraries.ss +++ b/src/tests.libraries.ss @@ -32,14 +32,21 @@ (define-syntax f (lambda (x) #'h)) (define-syntax h - (lambda (x) #'g))) + (lambda (x) #'g)) + (printf "F0 invoked\n")) + +;(library (F0 client) +; (export) +; (import (ikarus) (F0)) +; (unless (= (f) 17) +; (error #f "F0 client")) +; (printf "F0 client ok\n")) + (library (F0 client) (export) (import (ikarus) (F0)) - (unless (= (f) 17) - (error #f "F0 client")) - (printf "F0 client ok\n")) + (f)) (invoke (F0 client))