diff --git a/assemble.rkt b/assemble.rkt index db07ce7..86cb1d5 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -236,6 +236,11 @@ (third assembled-inputs) (first assembled-inputs) (second assembled-inputs))] + [(toplevel-lookup) + (format "(~a).valss[~a][~a]" + (third assembled-inputs) + (first assembled-inputs) + (second assembled-inputs))] [(primitive-procedure?) (format "(typeof(~a) === 'function')" (first assembled-inputs))] @@ -243,7 +248,11 @@ (format "new ExtendedEnvironment(~a, ~a)" (second assembled-inputs) (first assembled-inputs))] - [(lookup-variable-value) + [(extend-environment/prefix) + (format "new ExtendedPrefixEnvironment(~a, ~a)" + (second assembled-inputs) + (first assembled-inputs))] + #;[(lookup-variable-value) (format "((~a).globalBindings[~a])" (second assembled-inputs) (first assembled-inputs))]))) @@ -252,27 +261,34 @@ (define (assemble-op-statement op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name - [(define-variable!) - (format "(~a).globalBindings[~a] = ~a;" - (third assembled-inputs) - (first assembled-inputs) - (second assembled-inputs))] - [(set-variable-value!) - (format "(~a).globalBindings[~a] = ~a;" - (third assembled-inputs) - (first assembled-inputs) - (second assembled-inputs))] [(lexical-address-set!) (format "(~a).valss[~a][~a] = ~a;" (third assembled-inputs) (first assembled-inputs) (second assembled-inputs) (fourth assembled-inputs))] - [(check-bound-global!) - (format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error(\"Not bound: \" + ~a); }" - (second assembled-inputs) - (first assembled-inputs) - (first assembled-inputs))]))) + [(toplevel-set!) + (let ([depth (first assembled-inputs)] + [pos (second assembled-inputs)] + [name (third assembled-inputs)] + [env (fourth assembled-inputs)] + [val (fifth assembled-inputs)]) + (format "(~a).valss[~a][~a] = ~a;" + env + depth + pos + val))] + [(check-bound!) + (let ([depth (first assembled-inputs)] + [pos (second assembled-inputs)] + [name (third assembled-inputs)] + [env (fourth assembled-inputs)]) + (format "if ((~a).valss[~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~a); }" + env + depth + pos + name))]))) + diff --git a/compile.rkt b/compile.rkt index 1c14275..c6e03a6 100644 --- a/compile.rkt +++ b/compile.rkt @@ -3,18 +3,30 @@ (require "typed-structs.rkt" "lexical-env.rkt" "helpers.rkt" + "find-toplevel-variables.rkt" racket/list) -(provide compile) +(provide compile-top) -;; SICP, Chapter 5.5 ;; registers: env, argl, proc, val, cont ;; as well as the stack. (define all-regs '(env argl proc val cont)) - +(: compile-top (Expression Target Linkage -> InstructionSequence)) +(define (compile-top exp target linkage) + (let*: ([names : (Listof Symbol) (find-toplevel-variables exp)] + [cenv : CompileTimeEnvironment (list (make-Prefix names))]) + (append-instruction-sequences + (make-instruction-sequence + '(env) + '(env) + `(,(make-AssignPrimOpStatement 'env + 'extend-environment/prefix + (list (make-Const names) + (make-Reg 'env))))) + (compile exp cenv target linkage)))) ;; compile: expression target linkage -> instruction-sequence @@ -82,29 +94,31 @@ (define (compile-variable exp cenv target linkage) (let ([lexical-pos (find-variable (Var-id exp) cenv)]) (cond - [(eq? lexical-pos 'not-found) - (end-with-linkage linkage - (make-instruction-sequence - '(env) - (list target) - ;; Slight modification: explicitly testing for - ;; global variable binding before lookup. - `(,(make-PerformStatement 'check-bound-global! - (list (make-Const (Var-id exp)) - (make-Reg 'env))) - ,(make-AssignPrimOpStatement target - 'lookup-variable-value - (list (make-Const (Var-id exp)) - (make-Reg 'env))))))] - [else + [(LocalAddress? lexical-pos) (end-with-linkage linkage (make-instruction-sequence '(env) (list target) `(,(make-AssignPrimOpStatement target 'lexical-address-lookup - (list (make-Const (first lexical-pos)) - (make-Const (second lexical-pos)) + (list (make-Const (LocalAddress-depth lexical-pos)) + (make-Const (LocalAddress-pos lexical-pos)) + (make-Reg 'env))))))] + [(PrefixAddress? lexical-pos) + (end-with-linkage linkage + (make-instruction-sequence + '(env) + (list target) + `(,(make-PerformStatement 'check-bound! + (list (make-Const (PrefixAddress-depth lexical-pos)) + (make-Const (PrefixAddress-pos lexical-pos)) + (make-Const (PrefixAddress-name lexical-pos)) + (make-Reg 'env))) + ,(make-AssignPrimOpStatement target + 'toplevel-lookup + (list (make-Const (PrefixAddress-depth lexical-pos)) + (make-Const (PrefixAddress-pos lexical-pos)) + (make-Const (PrefixAddress-name lexical-pos)) (make-Reg 'env))))))]))) @@ -116,20 +130,7 @@ [lexical-address (find-variable var cenv)]) (cond - [(eq? lexical-address 'not-found) - (end-with-linkage - linkage - (preserving '(env) - get-value-code - (make-instruction-sequence - '(env val) - (list target) - `(,(make-PerformStatement 'set-variable-value! - (list (make-Const var) - (make-Reg 'val) - (make-Reg 'env))) - ,(make-AssignImmediateStatement target (make-Const 'ok))))))] - [else + [(LocalAddress? lexical-address) (end-with-linkage linkage (preserving '(env) @@ -138,8 +139,23 @@ '(env val) (list target) `(,(make-PerformStatement 'lexical-address-set! - (list (make-Const (first lexical-address)) - (make-Const (second lexical-address)) + (list (make-Const (LocalAddress-depth lexical-address)) + (make-Const (LocalAddress-pos lexical-address)) + (make-Reg 'env) + (make-Reg 'val))) + ,(make-AssignImmediateStatement target (make-Const 'ok))))))] + [(PrefixAddress? lexical-address) + (end-with-linkage + linkage + (preserving '(env) + get-value-code + (make-instruction-sequence + '(env val) + (list target) + `(,(make-PerformStatement 'toplevel-set! + (list (make-Const (PrefixAddress-depth lexical-address)) + (make-Const (PrefixAddress-pos lexical-address)) + (make-Const (PrefixAddress-name lexical-address)) (make-Reg 'env) (make-Reg 'val))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) @@ -148,22 +164,29 @@ ;; FIXME: exercise 5.43 (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-definition exp cenv target linkage) - (let ([var (Def-variable exp)] - [get-value-code - (compile (Def-value exp) cenv 'val 'next)]) - (end-with-linkage - linkage - (preserving - '(env) - get-value-code - (make-instruction-sequence - '(env val) - (list target) - `(,(make-PerformStatement 'define-variable! - (list (make-Const var) - (make-Reg 'val) - (make-Reg 'env))) - ,(make-AssignImmediateStatement target (make-Const 'ok)))))))) + (let* ([var (Def-variable exp)] + [lexical-pos (find-variable var cenv)] + [get-value-code + (compile (Def-value exp) cenv 'val 'next)]) + (cond + [(LocalAddress? lexical-pos) + (error 'compile-definition "Defintion not at toplevel")] + [(PrefixAddress? lexical-pos) + (end-with-linkage + linkage + (preserving + '(env) + get-value-code + (make-instruction-sequence + '(env val) + (list target) + `(,(make-PerformStatement 'toplevel-set! + (list (make-Const (PrefixAddress-depth lexical-pos)) + (make-Const (PrefixAddress-pos lexical-pos)) + (make-Const var) + (make-Reg 'env) + (make-Reg 'val))) + ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) diff --git a/lexical-env.rkt b/lexical-env.rkt index d6a9406..b4eb97f 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -19,9 +19,14 @@ (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv] [depth : Natural 0]) (cond [(empty? cenv) - 'not-found] + (error 'find-variable "Unable to find ~s in the environment" name)] + [(Prefix? (first cenv)) + (cond [(member name (Prefix-names (first cenv))) + (make-PrefixAddress depth (find-pos name (Prefix-names (first cenv))) name)] + [else + (loop (rest cenv) (add1 depth))])] [(member name (first cenv)) - (list depth (find-pos name (first cenv)))] + (make-LocalAddress depth (find-pos name (first cenv)))] [else (loop (rest cenv) (add1 depth))]))) diff --git a/package.rkt b/package.rkt index 833833d..a86f14f 100644 --- a/package.rkt +++ b/package.rkt @@ -17,10 +17,9 @@ (copy-port ip op))) (newline op) (fprintf op "var invoke = ") - (assemble/write-invoke (statements (compile (parse source-code) - '() - 'val - 'return)) + (assemble/write-invoke (statements (compile-top (parse source-code) + 'val + 'return)) op) (fprintf op ";\n")) @@ -35,7 +34,7 @@ 1 (* (factorial (- n 1)) n)))) -(test '(begin +#;(test '(begin (define (factorial n) (fact-iter n 1)) (define (fact-iter n acc) @@ -43,13 +42,13 @@ acc (fact-iter (- n 1) (* acc n)))))) -(test '(define (gauss n) +#;(test '(define (gauss n) (if (= n 0) 0 (+ (gauss (- n 1)) n)))) -(test '(define (fib n) +#;(test '(define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) diff --git a/runtime.js b/runtime.js index ef38325..68e23bd 100644 --- a/runtime.js +++ b/runtime.js @@ -32,6 +32,21 @@ var TopEnvironment = function() { this.valss = []; }; +var ExtendedPrefixEnvironment = function(parent, vs) { + var vals = []; + while(vs) { + if (parent.globalBindings[vs[0]]) { + vals.push(parent.globalBindings[vs[0]]); + } else { + vals.push(undefined); + } + vs = vs[1]; + } + this.valss = parent.valss.slice(); + this.valss.unshift(vals); + this.globalBindings = parent.globalBindings; +}; + var ExtendedEnvironment = function(parent, vs) { var vals = []; while(vs) { diff --git a/typed-structs.rkt b/typed-structs.rkt index f9db437..339c973 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -73,18 +73,23 @@ (define-type PrimitiveOperator (U 'compiled-procedure-entry 'compiled-procedure-env 'make-compiled-procedure + 'false? 'cons 'list 'apply-primitive-procedure + 'lexical-address-lookup + 'toplevel-lookup + 'extend-environment - 'lookup-variable-value)) + 'extend-environment/prefix)) + (define-type TestOperator (U 'false? 'primitive-procedure?)) -(define-type PerformOperator (U 'define-variable! - 'set-variable-value! + +(define-type PerformOperator (U 'toplevel-set! 'lexical-address-set! - 'check-bound-global!)) + 'check-bound!)) @@ -138,10 +143,17 @@ ;; Lexical environments +;; A toplevel prefix contains a list of toplevel variables. +(define-struct: Prefix ([names : (Listof Symbol)])) ;; A compile-time environment is a (listof (listof symbol)). ;; A lexical address is either a 2-tuple (depth pos), or 'not-found. -(define-type CompileTimeEnvironment (Listof (Listof Symbol))) -(define-type LexicalAddress (U (List Number Number) 'not-found)) +(define-type CompileTimeEnvironment (Listof (U (Listof Symbol) + Prefix))) +(define-type LexicalAddress (U LocalAddress PrefixAddress)) -(define-struct: Prefix ([names : (Listof Symbol)])) \ No newline at end of file +(define-struct: LocalAddress ([depth : Natural] + [pos : Natural])) +(define-struct: PrefixAddress ([depth : Natural] + [pos : Natural] + [name : Symbol])) \ No newline at end of file