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

NEW: ikarus --r6rs-repl <script-name> 

runs the script according to the R6RS semantics, then starts a
  repl in an interaction environment made of everything visible
  (imported and defined) in the script.

  Use cases include:
  * debugging a script.
  * starting ikarus in some predefined environment, e.g., 
       $ ikarus --r6rs-repl rnrs.ss
    where rnrs.ss contains (import (rnrs))

  Also, interaction-environment is made a parameter with an initial
  value set prior to entering the repl.
This commit is contained in:
Abdulaziz Ghuloum 2009-05-31 13:32:33 +03:00
parent 5f4151a2e9
commit 471921fcc7
4 changed files with 131 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
scheme/ikarus.main.ss
View File

@ -142,6 +142,13 @@
(die 'ikarus "--r6rs-script requires a script name")] (die 'ikarus "--r6rs-script requires a script name")]
[else [else
(values '() (car d) 'r6rs-script (cdr d) k)]))] (values '() (car d) 'r6rs-script (cdr d) k)]))]
[(string=? (car args) "--r6rs-repl")
(let ([d (cdr args)])
(cond
[(null? d)
(die 'ikarus "--r6rs-repl requires a script name")]
[else
(values '() (car d) 'r6rs-repl (cdr d) k)]))]
[(string=? (car args) "--compile-dependencies") [(string=? (car args) "--compile-dependencies")
(let ([d (cdr args)]) (let ([d (cdr args)])
(cond (cond
@ -202,7 +209,8 @@
(init-command-line-args) (init-command-line-args)
(cond (cond
[(eq? script-type 'r6rs-script) [(memq script-type '(r6rs-script r6rs-repl))
(let ([f (lambda ()
(doit (doit
(command-line-arguments (cons script args)) (command-line-arguments (cons script args))
(for-each (for-each
@ -212,7 +220,16 @@
((current-library-expander) src)) ((current-library-expander) src))
(read-source-file filename))) (read-source-file filename)))
files) files)
(load-r6rs-script script #f #t))] (load-r6rs-script script #f #t)))])
(cond
[(eq? script-type 'r6rs-script) (f)]
[else
(print-greeting)
(let ([env (f)])
(interaction-environment env)
(new-cafe
(lambda (x)
(doit (eval x env)))))]))]
[(eq? script-type 'compile) [(eq? script-type 'compile)
(assert-null files "--compile-dependencies") (assert-null files "--compile-dependencies")
(doit (doit

2
scheme/last-revision
View File

@ -1 +1 @@
1803 1804

120
scheme/psyntax.expander.ss
View File

@ -157,6 +157,19 @@
(lambda () (lambda ()
(make-rib '() '() '() #f))) (make-rib '() '() '() #f)))
(define (top-marked-symbols rib)
(let-values ([(sym* mark**)
(let ([sym* (rib-sym* rib)] [mark** (rib-mark** rib)])
(if (rib-sealed/freq rib)
(values (vector->list sym*) (vector->list mark**))
(values sym* mark**)))])
(let f ([sym* sym*] [mark** mark**])
(cond
[(null? sym*) '()]
[(equal? (car mark**) top-mark*)
(cons (car sym*) (f (cdr sym*) (cdr mark**)))]
[else (f (cdr sym*) (cdr mark**))]))))
;;; For example, when processing a lambda's internal define, a new rib ;;; For example, when processing a lambda's internal define, a new rib
;;; is created and is added to the body of the lambda expression. ;;; is created and is added to the body of the lambda expression.
;;; When an internal definition is encountered, a new entry for the ;;; When an internal definition is encountered, a new entry for the
@ -2661,7 +2674,8 @@
[(global-ctv) [(global-ctv)
(let ([lib (cadr binding)] (let ([lib (cadr binding)]
[loc (cddr binding)]) [loc (cddr binding)])
(visit-library lib) (unless (eq? lib '*interaction*)
(visit-library lib))
(symbol-value loc))] (symbol-value loc))]
[else #f])))))) [else #f]))))))
(return x)))) (return x))))
@ -2677,7 +2691,8 @@
;;; FIXME: does not handle macro!? ;;; FIXME: does not handle macro!?
(let ((lib (car p)) (let ((lib (car p))
(loc (cdr p))) (loc (cdr p)))
(visit-library lib) (unless (eq? lib '*interaction*)
(visit-library lib))
(let ((x (symbol-value loc))) (let ((x (symbol-value loc)))
(let ((transformer (let ((transformer
(cond (cond
@ -2781,8 +2796,12 @@
(else "a non-expression")) (else "a non-expression"))
" was found where an expression was expected"))) " was found where an expression was expected")))
((mutable) ((mutable)
(let* ((lib (car value))
(loc (cdr value)))
(if (eq? lib '*interaction*)
(build-global-reference no-source loc)
(stx-error e (stx-error e
"attempt to reference an unexportable variable")) "attempt to reference an unexportable variable"))))
(else (else
;(assertion-violation 'chi-expr "invalid type " type (strip e '())) ;(assertion-violation 'chi-expr "invalid type " type (strip e '()))
(stx-error e "invalid expression")))))) (stx-error e "invalid expression"))))))
@ -2801,14 +2820,18 @@
((core-prim) ((core-prim)
(stx-error e "cannot modify imported core primitive")) (stx-error e "cannot modify imported core primitive"))
((global) ((global)
(stx-error e "attempt to modify imported binding")) (stx-error e "attempt to modify an immutable binding"))
((global-macro!) ((global-macro!)
(chi-expr (chi-global-macro value e r) r mr)) (chi-expr (chi-global-macro value e r) r mr))
((local-macro!) ((local-macro!)
(chi-expr (chi-local-macro value e r) r mr)) (chi-expr (chi-local-macro value e r) r mr))
((mutable) ((mutable)
(let ([lib (car value)] [loc (cdr value)])
(if (eq? lib '*interaction*)
(build-global-assignment no-source loc
(chi-expr v r mr))
(stx-error e (stx-error e
"attempt to assign to an unexportable variable")) "attempt to modify an unexportable variable"))))
(else (stx-error e)))))))) (else (stx-error e))))))))
(define (verify-formals fmls stx) (define (verify-formals fmls stx)
@ -3503,7 +3526,9 @@
(let ((ls '())) (let ((ls '()))
(case-lambda (case-lambda
(() ls) (() ls)
((x) (set! ls (set-cons x ls)))))) ((x)
(unless (eq? x '*interaction*)
(set! ls (set-cons x ls)))))))
(define inv-collector (define inv-collector
(make-parameter (make-parameter
@ -3566,7 +3591,6 @@
(let ((rib (make-top-rib subst-names subst-labels))) (let ((rib (make-top-rib subst-names subst-labels)))
(define (wrap x) (make-stx x top-mark* (list rib) '())) (define (wrap x) (make-stx x top-mark* (list rib) '()))
(let ((b* (map wrap b*)) (let ((b* (map wrap b*))
(main-exp* (map wrap main-exp*))
(rtc (make-collector)) (rtc (make-collector))
(vtc (make-collector))) (vtc (make-collector)))
(parameterize ((inv-collector rtc) (parameterize ((inv-collector rtc)
@ -3574,7 +3598,12 @@
(let-values (((init* r mr lex* rhs* internal-exp*) (let-values (((init* r mr lex* rhs* internal-exp*)
(chi-library-internal b* rib mix?))) (chi-library-internal b* rib mix?)))
(let-values (((exp-name* exp-id*) (let-values (((exp-name* exp-id*)
(parse-exports (append main-exp* internal-exp*)))) (parse-exports
(if (eq? main-exp* 'all)
(map wrap (top-marked-symbols rib))
(append
(map wrap main-exp*)
internal-exp*)))))
(seal-rib! rib) (seal-rib! rib)
(let* ((init* (chi-expr* init* r mr)) (let* ((init* (chi-expr* init* r mr))
(rhs* (chi-rhs* rhs* r mr))) (rhs* (chi-rhs* rhs* r mr)))
@ -3585,6 +3614,7 @@
"attempt to export mutated variable") "attempt to export mutated variable")
(let-values (((export-env global* macro*) (let-values (((export-env global* macro*)
(make-export-env/macros lex* loc* r))) (make-export-env/macros lex* loc* r)))
(unless (eq? main-exp* 'all)
(for-each (for-each
(lambda (s) (lambda (s)
(let ((name (car s)) (label (cdr s))) (let ((name (car s)) (label (cdr s)))
@ -3595,7 +3625,7 @@
(when (eq? type 'mutable) (when (eq? type 'mutable)
(syntax-violation 'export (syntax-violation 'export
errstr name)))))))) errstr name))))))))
export-subst) export-subst))
(let ((invoke-body (let ((invoke-body
(build-library-letrec* no-source (build-library-letrec* no-source
mix? mix?
@ -3667,13 +3697,6 @@
(assertion-violation 'expander (assertion-violation 'expander
"top-level program is missing an (import ---) clause")))) "top-level program is missing an (import ---) clause"))))
(define top-level-expander
(lambda (e*)
(let-values (((imp* b*) (parse-top-level-program e*)))
(let-values (((imp* invoke-req* visit-req* invoke-code
visit-code export-subst export-env)
(library-body-expander '() imp* b* #t)))
(values invoke-req* invoke-code)))))
;;; An env record encapsulates a substitution and a set of ;;; An env record encapsulates a substitution and a set of
;;; libraries. ;;; libraries.
@ -3771,6 +3794,13 @@
;;; Given a (library . _) s-expression, library-expander expands ;;; Given a (library . _) s-expression, library-expander expands
;;; it to core-form, registers it with the library manager, and ;;; it to core-form, registers it with the library manager, and
;;; returns its invoke-code, visit-code, subst and env. ;;; returns its invoke-code, visit-code, subst and env.
(define (initial-visit! macro*)
(for-each (lambda (x)
(let ((loc (car x)) (proc (cadr x)))
(set-symbol-value! loc proc)))
macro*))
(define library-expander (define library-expander
(case-lambda (case-lambda
((x filename verify-name) ((x filename verify-name)
@ -3782,11 +3812,6 @@
(let ((loc (car x)) (src (cddr x))) (let ((loc (car x)) (src (cddr x)))
(build-global-assignment no-source loc src))) (build-global-assignment no-source loc src)))
macro*)))) macro*))))
(define (visit! macro*)
(for-each (lambda (x)
(let ((loc (car x)) (proc (cadr x)))
(set-symbol-value! loc proc)))
macro*))
(let-values (((name ver imp* inv* vis* (let-values (((name ver imp* inv* vis*
invoke-code macro* export-subst export-env invoke-code macro* export-subst export-env
guard-code guard-req*) guard-code guard-req*)
@ -3798,7 +3823,7 @@
(vis* (map library-spec vis*)) (vis* (map library-spec vis*))
(inv* (map library-spec inv*)) (inv* (map library-spec inv*))
(guard-req* (map library-spec guard-req*)) (guard-req* (map library-spec guard-req*))
(visit-proc (lambda () (visit! macro*))) (visit-proc (lambda () (initial-visit! macro*)))
(invoke-proc (invoke-proc
(lambda () (eval-core (expanded->core invoke-code)))) (lambda () (eval-core (expanded->core invoke-code))))
(visit-code (build-visit-code macro*)) (visit-code (build-visit-code macro*))
@ -4044,28 +4069,57 @@
(define syntax->datum (define syntax->datum
(lambda (x) (stx->datum x))) (lambda (x) (stx->datum x)))
(define top-level-expander
(lambda (e*)
(let-values (((imp* b*) (parse-top-level-program e*)))
(let-values (((imp* invoke-req* visit-req* invoke-code
macro* export-subst export-env)
(library-body-expander 'all imp* b* #t)))
(values invoke-req* invoke-code macro*
export-subst export-env)))))
(define compile-r6rs-top-level (define compile-r6rs-top-level
(lambda (x*) (lambda (x*)
(let-values (((lib* invoke-code) (top-level-expander x*))) (let-values (((lib* invoke-code macro* export-subst export-env)
(top-level-expander x*)))
(lambda () (lambda ()
(for-each invoke-library lib*) (for-each invoke-library lib*)
(eval-core (expanded->core invoke-code)))))) (initial-visit! macro*)
(eval-core (expanded->core invoke-code))
(make-interaction-env
(subst->rib export-subst)
(map
(lambda (x)
(let ([label (car x)] [binding (cdr x)])
(let ([type (car binding)] [val (cdr binding)])
(cons* label type '*interaction* val))))
export-env)
'())))))
(define (new-interaction-environment) (define (subst->rib subst)
(let ((lib (find-library-by-name (let ([rib (make-empty-rib)])
(base-of-interaction-library)))
(rib (make-empty-rib)))
(let ((subst (library-subst lib)))
(set-rib-sym*! rib (map car subst)) (set-rib-sym*! rib (map car subst))
(set-rib-mark**! rib (set-rib-mark**! rib
(map (lambda (x) top-mark*) subst)) (map (lambda (x) top-mark*) subst))
(set-rib-label*! rib (map cdr subst))) (set-rib-label*! rib (map cdr subst))
(make-interaction-env rib '() '()))) rib))
(define (new-interaction-environment)
(let ((lib (find-library-by-name
(base-of-interaction-library))))
(let ((rib (subst->rib (library-subst lib))))
(make-interaction-env rib '() '()))))
(define interaction-environment (define interaction-environment
(let ((e #f)) (let ((e #f))
(lambda () (case-lambda
(or e (begin (set! e (new-interaction-environment)) e))))) [()
(or e (begin (set! e (new-interaction-environment)) e))]
[(x)
(unless (environment? x)
(assertion-violation 'interaction-environment
"not an environment" x))
(set! e x)])))
(define top-level-context (make-parameter #f)) (define top-level-context (make-parameter #f))