conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* added a loader for top-level r6rs scripts.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-09 07:35:31 -04:00
parent 7494c29bba
commit 8c2b318648
5 changed files with 102 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

24
src/ikarus.load.ss
View File

@ -1,9 +1,9 @@
(library (ikarus load) (library (ikarus load)
(export load) (export load load-r6rs-top-level)
(import (import
(except (ikarus) load) (except (ikarus) load)
(only (ikarus syntax) eval-top-level) (only (ikarus syntax) eval-top-level eval-r6rs-top-level)
(only (ikarus reader) read-initial)) (only (ikarus reader) read-initial))
(define load-handler (define load-handler
@ -28,4 +28,22 @@
(unless (eof-object? x) (unless (eof-object? x)
(eval-proc x) (eval-proc x)
(read-and-eval p eval-proc))) (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))))
)

31
src/ikarus.main.ss
View File

@ -17,24 +17,39 @@
(library (ikarus interaction) (library (ikarus interaction)
(export) (export)
(import (ikarus) (ikarus greeting)) (import (ikarus)
(let-values ([(files script args) (ikarus greeting)
(only (ikarus load) load-r6rs-top-level))
(let-values ([(files script script-type args)
(let f ([args (command-line-arguments)]) (let f ([args (command-line-arguments)])
(cond (cond
[(null? args) (values '() #f '())] [(null? args) (values '() #f #f '())]
[(string=? (car args) "--") [(string=? (car args) "--")
(values '() #f (cdr args))] (values '() #f #f (cdr args))]
[(string=? (car args) "--script") [(string=? (car args) "--script")
(let ([d (cdr args)]) (let ([d (cdr args)])
(cond (cond
[(null? d) [(null? d)
(error #f "--script requires a script name")] (error #f "--script requires a script name")]
[else [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 [else
(let-values ([(f* script a*) (f (cdr args))]) (let-values ([(f* script script-type a*) (f (cdr args))])
(values (cons (car args) f*) script a*))]))]) (values (cons (car args) f*) script script-type a*))]))])
(cond (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 [script ; no greeting, no cafe
(command-line-arguments (cons script args)) (command-line-arguments (cons script args))
(for-each load files) (for-each load files)

56
src/ikarus.syntax.ss
View File

@ -8,7 +8,7 @@
(library (ikarus syntax) (library (ikarus syntax)
(export identifier? syntax-dispatch (export identifier? syntax-dispatch
generate-temporaries free-identifier=? syntax-error generate-temporaries free-identifier=? syntax-error
boot-library-expand eval-top-level) eval-r6rs-top-level boot-library-expand eval-top-level)
(import (import
(ikarus library-manager) (ikarus library-manager)
(only (ikarus compiler) eval-core) (only (ikarus compiler) eval-core)
@ -1675,12 +1675,6 @@
(build-letrec* no-source (build-letrec* no-source
(reverse lex*) (reverse rhs*) (reverse lex*) (reverse rhs*)
(build-sequence no-source init*))))))) (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 (define chi-internal-module
(lambda (e r mr lex* rhs* mod** kwd*) (lambda (e r mr lex* rhs* mod** kwd*)
(define parse-module (define parse-module
@ -1763,7 +1757,10 @@
[(_ x* ...) [(_ x* ...)
(chi-body* (append x* (cdr e*)) (chi-body* (append x* (cdr e*))
r mr lex* rhs* mod** kwd* rib top?)])] 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) [(local-macro)
(chi-body* (chi-body*
(cons (add-subst rib (chi-local-macro value e)) (cdr e*)) (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
@ -1965,6 +1962,12 @@
(unless (procedure? x) (unless (procedure? x)
(error 'vis-collector "~s is not a procedure" x)) (error 'vis-collector "~s is not a procedure" x))
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 (define core-library-expander
(lambda (e) (lambda (e)
(let-values ([(name exp-int* exp-ext* imp* b*) (parse-library e)]) (let-values ([(name exp-int* exp-ext* imp* b*) (parse-library e)])
@ -1976,7 +1979,7 @@
(parameterize ([inv-collector rtc] (parameterize ([inv-collector rtc]
[vis-collector vtc]) [vis-collector vtc])
(let-values ([(init* r mr lex* rhs*) (let-values ([(init* r mr lex* rhs*)
(chi-library-internal b* rib)]) (chi-library-internal b* rib #f)])
(seal-rib! rib) (seal-rib! rib)
(let ([rhs* (chi-rhs* rhs* r mr)]) (let ([rhs* (chi-rhs* rhs* r mr)])
(let ([invoke-body (if (and (null? init*) (null? lex*)) (let ([invoke-body (if (and (null? init*) (null? lex*))
@ -1994,6 +1997,35 @@
(build-letrec* no-source lex* rhs* invoke-body) (build-letrec* no-source lex* rhs* invoke-body)
macro* macro*
export-subst export-env))))))))))))) 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*) (define (visit! macro*)
(for-each (lambda (x) (for-each (lambda (x)
(let ([loc (car x)] [proc (cadr x)]) (let ([loc (car x)] [proc (cadr x)])
@ -2083,6 +2115,12 @@
(apply string-append args) (apply string-append args)
(strip x '())))) (strip x '()))))
(define identifier? (lambda (x) (id? 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 (define eval-top-level
(lambda (x) (lambda (x)
(unless (pair? x) (unless (pair? x)

15
src/tests.libraries.ss
View File

@ -32,14 +32,21 @@
(define-syntax f (define-syntax f
(lambda (x) #'h)) (lambda (x) #'h))
(define-syntax 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) (library (F0 client)
(export) (export)
(import (ikarus) (F0)) (import (ikarus) (F0))
(unless (= (f) 17) (f))
(error #f "F0 client"))
(printf "F0 client ok\n"))
(invoke (F0 client)) (invoke (F0 client))