suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

getting set! to work

Browse Source
This commit is contained in:
Danny Yoo 2011-03-23 17:47:43 -04:00
parent 656d950846
commit b433c6e6c7
3 changed files with 63 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
lexical-env.rkt
View File

@ -74,9 +74,12 @@
(: extend-lexical-environment/names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment))
(define (extend-lexical-environment/names cenv names)
(append (map (lambda: ([n : Symbol]) (make-NamedBinding n #f #f)) names) cenv))
(: extend-lexical-environment/names (CompileTimeEnvironment (Listof Symbol) (Listof Boolean) ->
CompileTimeEnvironment))
(define (extend-lexical-environment/names cenv names boxed?)
(append (map (lambda: ([n : Symbol]
[b : Boolean]) (make-NamedBinding n #f b)) names boxed?)
cenv))
(: extend-lexical-environment/parameter-names (CompileTimeEnvironment (Listof Symbol) (Listof Boolean) -> CompileTimeEnvironment))
(define (extend-lexical-environment/parameter-names cenv names boxed?)

31
parse.rkt
View File

@ -385,26 +385,41 @@
[(= 0 (length vars))
(parse `(begin ,@body) cenv)]
[(= 1 (length vars))
(make-Let1 (parameterize ([current-defined-name (first vars)])
(parse (car rhss) (extend-lexical-environment/placeholders cenv 1)))
(parse `(begin ,@body)
(extend-lexical-environment/names cenv (list (first vars)))))]
(let* ([mutated? (and (member (first vars) (find-mutated-names `(begin ,@body))) #t)]
[let-body (parse `(begin ,@body)
(extend-lexical-environment/names
cenv
(list (first vars))
(list mutated?)))])
(make-Let1 (parameterize ([current-defined-name (first vars)])
(parse (car rhss) (extend-lexical-environment/placeholders cenv 1)))
(if mutated?
(make-BoxEnv 0 let-body)
let-body)))]
[else
(let ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))])
(let* ([rhs-cenv (extend-lexical-environment/placeholders cenv (length vars))]
[mutated (find-mutated-names `(begin ,@body))]
[any-mutated? (ormap (lambda (n) (and (member n mutated) #t)) vars)])
(make-LetVoid (length vars)
(seq (append
(map (lambda (var rhs index)
(make-InstallValue index
(parameterize ([current-defined-name var])
(parse rhs rhs-cenv))
#f))
any-mutated?))
vars
rhss
(build-list (length rhss) (lambda (i) i)))
(list (parse `(begin ,@body)
(extend-lexical-environment/names cenv vars)))))
#f))])))
(extend-lexical-environment/names
cenv vars
(build-list (length vars)
(lambda (i)
any-mutated?)))))))
any-mutated?))])))
;; Letrec's currently doing a set! kind of thing.
(define (parse-letrec exp cenv)
(let ([vars (let-variables exp)]
[rhss (let-rhss exp)]

34
test-parse.rkt
View File

@ -309,3 +309,37 @@
(make-App (make-LocalRef 1 #t)
(list (make-LocalRef 2 #t)))))
#t)))
(test (parse '(let ([x 0])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix '(add1))
(make-Let1 (make-Constant 0)
(make-BoxEnv 0
(make-Lam #f 0
(make-InstallValue
1
(make-App (make-ToplevelRef 1 0)
(list (make-LocalRef 2 #t)))
#t)
'(1 0)))))) ;; x is 0, prefix is 1
(test (parse '(let ([x 0]
[y 1])
(lambda ()
(set! x (add1 x)))))
(make-Top (make-Prefix '(add1))
(make-LetVoid 2
(make-Seq (list
(make-InstallValue 0 (make-Constant 0) #t)
(make-InstallValue 1 (make-Constant 1) #t)
(make-Lam #f 0
(make-InstallValue
1
(make-App (make-ToplevelRef 1 0)
(list (make-LocalRef 2 #t)))
#t)
'(2 0))))
#t)))