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

Fixes bug 164730: mutation of export

This commit is contained in:
Abdulaziz Ghuloum 2007-11-23 16:07:38 -05:00
parent d74b82fe7d
commit 358ba407aa
3 changed files with 39 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

2
scheme/last-revision
View File

@ -1 +1 @@
1122 1123

46
scheme/psyntax.expander.ss
View File

@ -36,6 +36,7 @@
(rnrs lists) (rnrs lists)
(rnrs control) (rnrs control)
(rnrs io simple) (rnrs io simple)
(rnrs mutable-pairs)
(psyntax library-manager) (psyntax library-manager)
(psyntax builders) (psyntax builders)
(psyntax compat) (psyntax compat)
@ -547,7 +548,7 @@
((lexical core-prim macro macro! global local-macro ((lexical core-prim macro macro! global local-macro
local-macro! global-macro global-macro! local-macro! global-macro global-macro!
displaced-lexical syntax import $module $core-rtd displaced-lexical syntax import $module $core-rtd
library) library mutable)
(values type (binding-value b) id)) (values type (binding-value b) id))
(else (values 'other #f #f)))))) (else (values 'other #f #f))))))
((syntax-pair? e) ((syntax-pair? e)
@ -557,7 +558,7 @@
(b (label->binding label r)) (b (label->binding label r))
(type (binding-type b))) (type (binding-type b)))
(unless label ;;; fail early. (unless label ;;; fail early.
(stx-error e "unbound identifier")) (stx-error id "unbound identifier"))
(case type (case type
((define define-syntax core-macro begin macro ((define define-syntax core-macro begin macro
macro! local-macro local-macro! global-macro macro! local-macro local-macro! global-macro
@ -770,9 +771,12 @@
(else (mkstx sym top-mark* '())))))) (else (mkstx sym top-mark* '()))))))
;;; macros ;;; macros
(define lexical-var car)
(define lexical-mutable? cdr)
(define set-lexical-mutable! set-cdr!)
(define add-lexical (define add-lexical
(lambda (lab lex r) (lambda (lab lex r)
(cons (cons* lab 'lexical lex) r))) (cons (cons* lab 'lexical lex #f) r)))
;;; ;;;
(define add-lexicals (define add-lexicals
(lambda (lab* lex* r) (lambda (lab* lex* r)
@ -2349,7 +2353,7 @@
(build-primref no-source name))) (build-primref no-source name)))
((call) (chi-application e r mr)) ((call) (chi-application e r mr))
((lexical) ((lexical)
(let ((lex value)) (let ((lex (lexical-var value)))
(build-lexical-reference no-source lex))) (build-lexical-reference no-source lex)))
((global-macro global-macro!) ((global-macro global-macro!)
(chi-expr (chi-global-macro value e) r mr)) (chi-expr (chi-global-macro value e) r mr))
@ -2396,6 +2400,9 @@
((import) "an import declaration") ((import) "an import declaration")
(else "a non-expression")) (else "a non-expression"))
" was found where an expression was expected"))) " was found where an expression was expected")))
((mutable)
(stx-error e
"attempt to reference an unexportable variable"))
(else (else
;(error 'chi-expr "invalid type " type (strip e '())) ;(error 'chi-expr "invalid type " type (strip e '()))
(stx-error e "invalid expression")))))) (stx-error e "invalid expression"))))))
@ -2407,8 +2414,9 @@
(let-values (((type value kwd) (syntax-type x r))) (let-values (((type value kwd) (syntax-type x r)))
(case type (case type
((lexical) ((lexical)
(set-lexical-mutable! value #t)
(build-lexical-assignment no-source (build-lexical-assignment no-source
value (lexical-var value)
(chi-expr v r mr))) (chi-expr v r mr)))
((core-prim) ((core-prim)
(stx-error e "cannot modify imported core primitive")) (stx-error e "cannot modify imported core primitive"))
@ -2416,11 +2424,13 @@
(let ((loc (gen-global-var-binding x e))) (let ((loc (gen-global-var-binding x e)))
(let ((rhs (chi-expr v r mr))) (let ((rhs (chi-expr v r mr)))
(build-global-assignment no-source loc rhs)))) (build-global-assignment no-source loc rhs))))
; (stx-error e "cannot modify imported identifier in"))
((global-macro!) ((global-macro!)
(chi-expr (chi-global-macro value e) r mr)) (chi-expr (chi-global-macro value e) r mr))
((local-macro!) ((local-macro!)
(chi-expr (chi-local-macro value e) r mr)) (chi-expr (chi-local-macro value e) r mr))
((mutable)
(stx-error e
"attempt to assign to an unexportable variable"))
(else (stx-error e)))))))) (else (stx-error e))))))))
(define chi-lambda-clause (define chi-lambda-clause
@ -3099,8 +3109,20 @@
(init* (chi-expr* init* r mr))) (init* (chi-expr* init* r mr)))
(unseal-rib! rib) (unseal-rib! rib)
(let ((export-subst (make-export-subst exp-int* exp-ext* rib))) (let ((export-subst (make-export-subst exp-int* exp-ext* rib)))
(define errstr
"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)))
(for-each
(lambda (s)
(let ([name (car s)] [label (cdr s)])
(let ([p (assq label export-env)])
(when p
(let ([b (cdr p)])
(let ([type (car b)])
(when (eq? type 'mutable)
(error 'export errstr name))))))))
export-subst)
(let ((invoke-body (let ((invoke-body
(build-library-letrec* no-source (build-library-letrec* no-source
lex* loc* rhs* lex* loc* rhs*
@ -3300,11 +3322,15 @@
(let ((label (car x)) (b (cdr x))) (let ((label (car x)) (b (cdr x)))
(case (binding-type b) (case (binding-type b)
((lexical) ((lexical)
(let ((loc (lookup (binding-value b)))) (let ([v (binding-value b)])
(let ((loc (lookup (lexical-var v)))
(type (if (lexical-mutable? v)
'mutable
'global)))
(f (cdr r) (f (cdr r)
(cons (cons* label 'global loc) env) (cons (cons* label type loc) env)
(cons (cons (binding-value b) loc) global*) (cons (cons (lexical-var v) loc) global*)
macro*))) macro*))))
((local-macro) ((local-macro)
(let ((loc (gensym))) (let ((loc (gensym)))
(f (cdr r) (f (cdr r)