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

- fixed errors where multiple internal definitions were silently 

allowed if typed in the repl.
- added some tests for the interaction environment.
This commit is contained in:
Abdulaziz Ghuloum 2008-10-31 16:22:25 -04:00
parent db2604ad2a
commit 359aa1d2c9
5 changed files with 189 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1653 1654

1
scheme/makefile.ss
View File

@ -1095,6 +1095,7 @@
[quotient i r5 se] [quotient i r5 se]
[scheme-report-environment i r5 se] [scheme-report-environment i r5 se]
[interaction-environment i r5 se] [interaction-environment i r5 se]
[new-interaction-environment i]
[close-port i r ip] [close-port i r ip]
[eol-style i r ip] [eol-style i r ip]
[error-handling-mode i r ip] [error-handling-mode i r ip]

153
scheme/psyntax.expander.ss
View File

@ -31,7 +31,8 @@
null-environment scheme-report-environment null-environment scheme-report-environment
interaction-environment interaction-environment
ellipsis-map assertion-error ellipsis-map assertion-error
environment environment? environment-symbols) environment environment? environment-symbols
new-interaction-environment)
(import (import
(except (rnrs) (except (rnrs)
environment environment? identifier? environment environment? identifier?
@ -121,29 +122,25 @@
;;; create new label for new binding ;;; create new label for new binding
(gensym)))))) (gensym))))))
(define (gen-define-label+loc id rib sd?)
(if sd?
(values (gensym) (gen-lexical id))
(let ([env (top-level-context)])
(let ((label (gen-top-level-label id rib))
(locs (interaction-env-locs env)))
(values label
(cond
((assq label locs) => cdr)
(else
(let ((loc (gen-lexical id)))
(set-interaction-env-locs! env
(cons (cons label loc) locs))
loc))))))))
(define (gen-define-label+loc id rib) (define (gen-define-label id rib sd?)
(cond (if sd?
((top-level-context) => (gensym)
(lambda (env) (gen-top-level-label id rib)))
(let ((label (gen-top-level-label id rib))
(locs (interaction-env-locs env)))
(values label
(cond
((assq label locs) => cdr)
(else
(let ((loc (gen-lexical id)))
(set-interaction-env-locs! env
(cons (cons label loc) locs))
loc)))))))
(else (values (gensym) (gen-lexical id)))))
(define (gen-define-label id rib)
(cond
((top-level-context)
(gen-top-level-label id rib))
(else (gensym))))
;;; A rib is a record constructed at every lexical contour in the ;;; A rib is a record constructed at every lexical contour in the
@ -166,7 +163,7 @@
;;; extensible, or sealed. An extensible rib looks like: ;;; extensible, or sealed. An extensible rib looks like:
;;; #<rib list-of-symbols list-of-list-of-marks list-of-labels #f> ;;; #<rib list-of-symbols list-of-list-of-marks list-of-labels #f>
(define (extend-rib! rib id label) (define (extend-rib! rib id label sd?)
(define (find sym mark* sym* mark** label*) (define (find sym mark* sym* mark** label*)
(and (pair? sym*) (and (pair? sym*)
(if (and (eq? sym (car sym*)) (same-marks? mark* (car mark**))) (if (and (eq? sym (car sym*)) (same-marks? mark* (car mark**)))
@ -184,7 +181,7 @@
(lambda (p) (lambda (p)
(unless (eq? label (car p)) (unless (eq? label (car p))
(cond (cond
((top-level-context) ((not sd?) ;(top-level-context)
;;; XXX override label ;;; XXX override label
(set-car! p label)) (set-car! p label))
(else (else
@ -594,8 +591,8 @@
(lambda (env) (lambda (env)
;;; fabricate binding ;;; fabricate binding
(let ((rib (interaction-env-rib env))) (let ((rib (interaction-env-rib env)))
(let-values (((lab loc_) (gen-define-label+loc id rib))) (let-values (((lab _loc) (gen-define-label+loc id rib #f)))
(extend-rib! rib id lab) (extend-rib! rib id lab #t) ;;; FIXME
lab)))) lab))))
(else #f)))) (else #f))))
@ -2921,9 +2918,9 @@
(lambda (e* r mr) (lambda (e* r mr)
(let ((rib (make-empty-rib))) (let ((rib (make-empty-rib)))
(let-values (((e* r mr lex* rhs* mod** kwd* _exp*) (let-values (((e* r mr lex* rhs* mod** kwd* _exp*)
(chi-body* (map (lambda (x) (add-subst rib x)) (chi-body*
(syntax->list e*)) (map (lambda (x) (add-subst rib x)) (syntax->list e*))
r mr '() '() '() '() '() rib #f))) r mr '() '() '() '() '() rib #f #t)))
(when (null? e*) (when (null? e*)
(stx-error e* "no expression in body")) (stx-error e* "no expression in body"))
(let* ((init* (let* ((init*
@ -2975,7 +2972,7 @@
(let* ((rib (make-empty-rib)) (let* ((rib (make-empty-rib))
(e* (map (lambda (x) (add-subst rib x)) (syntax->list e*)))) (e* (map (lambda (x) (add-subst rib x)) (syntax->list e*))))
(let-values (((e* r mr lex* rhs* mod** kwd* _exp*) (let-values (((e* r mr lex* rhs* mod** kwd* _exp*)
(chi-body* e* r mr lex* rhs* mod** kwd* '() rib #f))) (chi-body* e* r mr lex* rhs* mod** kwd* '() rib #f #t)))
(let ((exp-lab* (let ((exp-lab*
(vector-map (vector-map
(lambda (x) (lambda (x)
@ -3005,7 +3002,7 @@
mod** kwd*))))))))) mod** kwd*)))))))))
(define chi-body* (define chi-body*
(lambda (e* r mr lex* rhs* mod** kwd* exp* rib top?) (lambda (e* r mr lex* rhs* mod** kwd* exp* rib mix? sd?)
(cond (cond
((null? e*) (values e* r mr lex* rhs* mod** kwd* exp*)) ((null? e*) (values e* r mr lex* rhs* mod** kwd* exp*))
(else (else
@ -3017,23 +3014,24 @@
(let-values (((id rhs) (parse-define e))) (let-values (((id rhs) (parse-define e)))
(when (bound-id-member? id kwd*) (when (bound-id-member? id kwd*)
(stx-error e "cannot redefine keyword")) (stx-error e "cannot redefine keyword"))
(let-values (((lab lex) (gen-define-label+loc id rib))) (let-values (((lab lex) (gen-define-label+loc id rib sd?)))
(extend-rib! rib id lab) (extend-rib! rib id lab sd?)
(chi-body* (cdr e*) (chi-body* (cdr e*)
(add-lexical lab lex r) mr (add-lexical lab lex r) mr
(cons lex lex*) (cons rhs rhs*) (cons lex lex*) (cons rhs rhs*)
mod** kwd* exp* rib top?)))) mod** kwd* exp* rib mix? sd?))))
((define-syntax) ((define-syntax)
(let-values (((id rhs) (parse-define-syntax e))) (let-values (((id rhs) (parse-define-syntax e)))
(when (bound-id-member? id kwd*) (when (bound-id-member? id kwd*)
(stx-error e "cannot redefine keyword")) (stx-error e "cannot redefine keyword"))
(let ((lab (gen-define-label id rib)) (let* ((lab (gen-define-label id rib sd?))
(expanded-rhs (expand-transformer rhs mr))) (expanded-rhs (expand-transformer rhs mr)))
(extend-rib! rib id lab) (extend-rib! rib id lab sd?)
(let ((b (make-eval-transformer expanded-rhs))) (let ((b (make-eval-transformer expanded-rhs)))
(chi-body* (cdr e*) (chi-body* (cdr e*)
(cons (cons lab b) r) (cons (cons lab b) mr) (cons (cons lab b) r) (cons (cons lab b) mr)
lex* rhs* mod** kwd* exp* rib top?))))) lex* rhs* mod** kwd* exp* rib
mix? sd?)))))
((let-syntax letrec-syntax) ((let-syntax letrec-syntax)
(syntax-match e () (syntax-match e ()
((_ ((xlhs* xrhs*) ...) xbody* ...) ((_ ((xlhs* xrhs*) ...) xbody* ...)
@ -3053,42 +3051,50 @@
(append (map (lambda (x) (add-subst xrib x)) xbody*) (cdr e*)) (append (map (lambda (x) (add-subst xrib x)) xbody*) (cdr e*))
(append (map cons xlab* xb*) r) (append (map cons xlab* xb*) r)
(append (map cons xlab* xb*) mr) (append (map cons xlab* xb*) mr)
lex* rhs* mod** kwd* exp* rib top?))))) lex* rhs* mod** kwd* exp* rib
mix? sd?)))))
((begin) ((begin)
(syntax-match e () (syntax-match e ()
((_ x* ...) ((_ x* ...)
(chi-body* (append x* (cdr e*)) (chi-body* (append x* (cdr e*))
r mr lex* rhs* mod** kwd* exp* rib top?)))) r mr lex* rhs* mod** kwd* exp* rib
mix? sd?))))
((global-macro global-macro!) ((global-macro global-macro!)
(chi-body* (chi-body*
(cons (add-subst rib (chi-global-macro value e)) (cons (add-subst rib (chi-global-macro value e))
(cdr e*)) (cdr e*))
r mr lex* rhs* mod** kwd* exp* rib top?)) r mr lex* rhs* mod** kwd* exp* rib
mix? sd?))
((local-macro local-macro!) ((local-macro local-macro!)
(chi-body* (chi-body*
(cons (add-subst rib (chi-local-macro value e)) (cons (add-subst rib (chi-local-macro value e))
(cdr e*)) (cdr e*))
r mr lex* rhs* mod** kwd* exp* rib top?)) r mr lex* rhs* mod** kwd* exp* rib
mix? sd?))
((macro macro!) ((macro macro!)
(chi-body* (chi-body*
(cons (add-subst rib (chi-macro value e)) (cons (add-subst rib (chi-macro value e))
(cdr e*)) (cdr e*))
r mr lex* rhs* mod** kwd* exp* rib top?)) r mr lex* rhs* mod** kwd* exp* rib mix?
sd?))
((module) ((module)
(let-values (((lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*) (let-values (((lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*)
(chi-internal-module e r mr lex* rhs* mod** kwd*))) (chi-internal-module e r mr lex* rhs* mod** kwd*)))
(vector-for-each (vector-for-each
(lambda (id lab) (extend-rib! rib id lab)) (lambda (id lab) (extend-rib! rib id lab sd?))
m-exp-id* m-exp-lab*) m-exp-id* m-exp-lab*)
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?))) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd*
exp* rib mix? sd?)))
((library) ((library)
(library-expander (stx->datum e)) (library-expander (stx->datum e))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?)) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp*
rib mix? sd?))
((export) ((export)
(syntax-match e () (syntax-match e ()
((_ exp-decl* ...) ((_ exp-decl* ...)
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* (chi-body* (cdr e*) r mr lex* rhs* mod** kwd*
(append exp-decl* exp*) rib top?)))) (append exp-decl* exp*) rib
mix? sd?))))
((import) ((import)
(let () (let ()
(define (module-import? e) (define (module-import? e)
@ -3125,15 +3131,16 @@
(module-import e r) (module-import e r)
(library-import e)))) (library-import e))))
(vector-for-each (vector-for-each
(lambda (id lab) (extend-rib! rib id lab)) (lambda (id lab) (extend-rib! rib id lab sd?))
id* lab*)) id* lab*))
(chi-body* (cdr e*) r mr lex* rhs* mod** kwd* exp* rib top?))) (chi-body* (cdr e*) r mr lex* rhs* mod** kwd*
exp* rib mix? sd?)))
(else (else
(if top? (if mix?
(chi-body* (cdr e*) r mr (chi-body* (cdr e*) r mr
(cons (gen-lexical 'dummy) lex*) (cons (gen-lexical 'dummy) lex*)
(cons (cons 'top-expr e) rhs*) (cons (cons 'top-expr e) rhs*)
mod** kwd* exp* rib top?) mod** kwd* exp* rib #t sd?)
(values e* r mr lex* rhs* mod** kwd* exp*))))))))))) (values e* r mr lex* rhs* mod** kwd* exp*)))))))))))
(define (expand-transformer expr r) (define (expand-transformer expr r)
@ -3427,7 +3434,7 @@
(lambda (name label) (lambda (name label)
(unless (symbol? name) (unless (symbol? name)
(error 'make-top-rib "BUG: not a symbol" name)) (error 'make-top-rib "BUG: not a symbol" name))
(extend-rib! rib (make-stx name top-mark* '() '()) label)) (extend-rib! rib (make-stx name top-mark* '() '()) label #t))
names labels) names labels)
rib)) rib))
@ -3465,9 +3472,9 @@
x))) x)))
(define chi-library-internal (define chi-library-internal
(lambda (e* rib top?) (lambda (e* rib mix?)
(let-values (((e* r mr lex* rhs* mod** _kwd* exp*) (let-values (((e* r mr lex* rhs* mod** _kwd* exp*)
(chi-body* e* '() '() '() '() '() '() '() rib top?))) (chi-body* e* '() '() '() '() '() '() '() rib mix? #t)))
(values (append (apply append (reverse mod**)) e*) (values (append (apply append (reverse mod**)) e*)
r mr (reverse lex*) (reverse rhs*) exp*)))) r mr (reverse lex*) (reverse rhs*) exp*))))
@ -3475,7 +3482,8 @@
(define chi-interaction-expr (define chi-interaction-expr
(lambda (e rib r) (lambda (e rib r)
(let-values (((e* r mr lex* rhs* mod** _kwd* _exp*) (let-values (((e* r mr lex* rhs* mod** _kwd* _exp*)
(chi-body* (list e) r r '() '() '() '() '() rib #t))) (chi-body* (list e) r r '() '() '() '() '() rib
#t #f)))
(let ((e* (expand-interaction-rhs*/init* (let ((e* (expand-interaction-rhs*/init*
(reverse lex*) (reverse rhs*) (reverse lex*) (reverse rhs*)
(append (apply append (reverse mod**)) e*) (append (apply append (reverse mod**)) e*)
@ -3487,7 +3495,7 @@
(values e r)))))) (values e r))))))
(define library-body-expander (define library-body-expander
(lambda (main-exp* imp* b* top?) (lambda (main-exp* imp* b* mix?)
(define itc (make-collector)) (define itc (make-collector))
(parameterize ((imp-collector itc) (parameterize ((imp-collector itc)
(top-level-context #f)) (top-level-context #f))
@ -3502,7 +3510,7 @@
(parameterize ((inv-collector rtc) (parameterize ((inv-collector rtc)
(vis-collector vtc)) (vis-collector vtc))
(let-values (((init* r mr lex* rhs* internal-exp*) (let-values (((init* r mr lex* rhs* internal-exp*)
(chi-library-internal b* rib top?))) (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 (append main-exp* internal-exp*))))
(seal-rib! rib) (seal-rib! rib)
@ -3527,7 +3535,8 @@
errstr name)))))))) errstr name))))))))
export-subst) export-subst)
(let ((invoke-body (let ((invoke-body
(build-library-letrec* no-source top? (build-library-letrec* no-source
mix?
lex* loc* rhs* lex* loc* rhs*
(if (null? init*) (if (null? init*)
(build-void) (build-void)
@ -3935,21 +3944,21 @@
(for-each invoke-library lib*) (for-each invoke-library lib*)
(eval-core (expanded->core invoke-code)))))) (eval-core (expanded->core invoke-code))))))
(define (new-interaction-environment)
(let ((lib (find-library-by-name
(base-of-interaction-library)))
(rib (make-empty-rib)))
(let ((subst (library-subst lib)))
(set-rib-sym*! rib (map car subst))
(set-rib-mark**! rib
(map (lambda (x) top-mark*) subst))
(set-rib-label*! rib (map cdr subst)))
(make-interaction-env rib '() '())))
(define interaction-environment (define interaction-environment
(let ((the-env #f)) (let ((e #f))
(lambda () (lambda ()
(or the-env (or e (begin (set! e (new-interaction-environment)) e)))))
(let ((lib (find-library-by-name
(base-of-interaction-library)))
(rib (make-empty-rib)))
(let ((subst (library-subst lib)))
(set-rib-sym*! rib (map car subst))
(set-rib-mark**! rib
(map (lambda (x) top-mark*) subst))
(set-rib-label*! rib (map cdr subst)))
(let ((env (make-interaction-env rib '() '())))
(set! the-env env)
env))))))
(define top-level-context (make-parameter #f)) (define top-level-context (make-parameter #f))

2
scheme/run-tests.ss
View File

@ -22,7 +22,7 @@
lists strings bytevectors hashtables fixnums bignums numerics lists strings bytevectors hashtables fixnums bignums numerics
bitwise enums pointers sorting io fasl reader case-folding bitwise enums pointers sorting io fasl reader case-folding
parse-flonums string-to-number bignum-to-flonum div-and-mod parse-flonums string-to-number bignum-to-flonum div-and-mod
fldiv-and-mod unicode normalization)) fldiv-and-mod unicode normalization repl))
(define (run-test-from-library x) (define (run-test-from-library x)
(printf "[testing ~a] ..." x) (printf "[testing ~a] ..." x)

105
scheme/tests/repl.ss Normal file
View File

@ -0,0 +1,105 @@
(library (tests repl)
(export run-tests)
(import (ikarus))
(define (run-tests)
(define e (new-interaction-environment))
(define (test-bound-procedure x)
(assert (procedure? (eval x e))))
(define (test-invalid-syntax x)
(assert
(guard (con
[(syntax-violation? con) #t]
[else #f])
(eval x e))))
(define-syntax assert-undefined
(syntax-rules ()
[(_ expr)
(assert
(guard (con
[(syntax-violation? con) #f]
[(undefined-violation? con) #t]
[else #f])
expr #f))]))
(define-syntax assert-syntax
(syntax-rules ()
[(_ expr)
(assert
(guard (con
[(syntax-violation? con) #t]
[else #f])
expr #f))]))
(define-syntax assert-assertion
(syntax-rules ()
[(_ expr)
(assert
(guard (con
[(assertion-violation? con) #t]
[else #f])
expr #f))]))
;;;
(for-each test-bound-procedure '(cons car cdr + -))
(for-each test-invalid-syntax '(lambda let else))
(eval '(define x '12) e)
(assert (eqv? 12 (eval 'x e)))
(eval '(define y (lambda (x) (+ x x))) e)
(assert (procedure? (eval 'y e)))
(assert (eqv? 12 (eval 'x e)))
(assert (eqv? 24 (eval '(y 12) e)))
(assert (eqv? 24 (eval '(y x) e)))
(eval '(define-syntax m (lambda (stx) #'x)) e)
(assert (eqv? 12 (eval '(m) e)))
(assert (eqv? 12 (eval 'm e)))
(assert (eqv? 12 (eval '(let ([x 13]) m) e)))
(assert (eqv? 12 (eval '(let ([x 13]) (m)) e)))
(eval '(define z (lambda () q)) e)
(assert (procedure? (eval 'z e)))
(assert-undefined (eval '(z) e))
(eval '(define q 113) e)
(assert (eqv? 113 (eval '(z) e)))
(eval '(define + '+) e)
(assert (eqv? '+ (eval '+ e)))
(assert-assertion (eval '(+ 1 2) e))
(eval '(import (only (rnrs) +)) e)
(assert (eqv? 3 (eval '(+ 1 2) e)))
(assert-syntax
(eval
'(let ()
(define x 1)
(define x 2)
x)
e))
(assert-syntax
(eval
'(let ()
(define-syntax x (identifier-syntax 1))
(define-syntax x (identifier-syntax 2))
x)
e))
(assert-syntax
(eval
'(let ()
(define x 1)
(define-syntax x (identifier-syntax 2))
x)
e))
(assert-syntax
(eval
'(let ()
(define-syntax x (identifier-syntax 2))
(define x 1)
x)
e))
)))