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)
(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))))
)

31
src/ikarus.main.ss
View File

@ -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)
(error #f "--script requires a script name")]
[else
(values '() (car d) (cdr d))]))]
[else
(let-values ([(f* script a*) (f (cdr args))])
(values (cons (car args) f*) script a*))]))])
(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 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)

56
src/ikarus.syntax.ss
View File

@ -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)

15
src/tests.libraries.ss
View File

@ -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))