Wow

15-compilation-part-2/main.rkt

@@ -15,7 +15,7 @@
            | { <TOY> <TOY> ... }
 |#
 
-(define-type BINDINGS (Listof (Listof Symbol)))
+(define-type BINDINGS = (Listof (Listof Symbol)))
 
 ;; A matching abstract syntax tree datatype:
 (define-type TOY
@@ -36,6 +36,32 @@
       (and (not (member (first xs) (rest xs)))
            (unique-list? (rest xs)))))
 
+; Parametric types having to end in '-of' is dumb.
+(define-type (Perhapsof A)
+             [Some A]
+             [None])
+
+(: index-of : Symbol (Listof Symbol) -> (Perhapsof Natural))
+(define (index-of name names)
+  (: loop : (Listof Symbol) Natural -> (Perhapsof Natural))
+  (define (loop remaining idx)
+    (cond [(null? remaining) (None)]
+          [(symbol=? name (first remaining)) (Some idx)]
+          [else (loop (rest remaining) (add1 idx))]))
+  (loop names 0))
+
+(: find-index : Symbol BINDINGS -> (Perhapsof (List Natural Natural)))
+(define (find-index name bindings)
+  (: loop : BINDINGS Natural -> (Perhapsof (List Natural Natural)))
+  (define (loop rest-bindings binding-idx)
+    (cond [(null? rest-bindings) (None)]
+          [else
+           (let ([name-idx (index-of name (first rest-bindings))])
+             (cases name-idx
+                    [(Some idx-in-scope) (Some (list binding-idx idx-in-scope))]
+                    [(None) (loop (rest rest-bindings) (add1 binding-idx))]))]))
+  (loop bindings 0))
+
 (: parse-sexpr : Sexpr -> TOY)
 ;; parses s-expressions into TOYs
 (define (parse-sexpr sexpr)
@@ -87,12 +113,7 @@
 ;;; ==================================================================
 ;;; Values and environments
 
-(define-type ENV
+(define-type ENV = (Listof (Listof (Boxof VAL))))
-  [EmptyEnv]
-  [FrameEnv FRAME ENV])
-
-;; a frame is an association list of names and values.
-(define-type FRAME = (Listof (List Symbol (Boxof VAL))))
 
 (define-type VAL
              [BogusV]
@@ -103,48 +124,44 @@
 ;; a single bogus value to use wherever needed
 (define the-bogus-value (BogusV))
 
-(: raw-extend : (Listof Symbol) (Listof (Boxof VAL)) ENV -> ENV)
+(: extend : (Listof VAL) ENV -> ENV)
-;; extends an environment with a new frame, given names and value
-;; boxes
-(define (raw-extend names boxed-values env)
-  (if (= (length names) (length boxed-values))
-    (FrameEnv (map (lambda ([name : Symbol] [boxed-val : (Boxof VAL)])
-                     (list name boxed-val))
-                   names boxed-values)
-              env)
-    (error 'raw-extend "arity mismatch for names: ~s" names)))
-
-(: extend : (Listof Symbol) (Listof VAL) ENV -> ENV)
 ;; extends an environment with a new frame (given plain values).
 (define (extend names values env)
-  (raw-extend names (map (inst box VAL) values) env))
+  (cons (map (inst box VAL) values) env))
 
-(: extend-rec : (Listof Symbol) (Listof (ENV -> VAL)) ENV -> ENV)
+(: extend-rec : (Listof (ENV -> VAL)) ENV -> ENV)
 ;; extends an environment with a new recursive frame (given compiled
 ;; expressions).
-(define (extend-rec names compiled-exprs env)
+(define (extend-rec compiled-exprs env)
-  (define new-env
+  (define new-boxes
-    (extend names
+    (map (λ (_) (box the-bogus-value)) compiled-exprs))
-            (map (lambda (_) the-bogus-value) compiled-exprs)
+  (define new-frame new-boxes)
-            env))
+  (define new-env (cons new-frame env))
   ;; note: no need to check the lengths here, since this is only
   ;; called for `bindrec', and the syntax make it impossible to have
   ;; different lengths
-  (for-each (lambda ([name : Symbol] [compiled : (ENV -> VAL)])
+  (for-each (lambda ([boxed-val : (Boxof VAL)] [compiled : (ENV -> VAL)])
-              (set-box! (lookup name new-env) (compiled new-env)))
+              (set-box! boxed-val (compiled new-env)))
-            names compiled-exprs)
+            new-boxes compiled-exprs)
   new-env)
 
-(: lookup : Symbol ENV -> (Boxof VAL))
+(: framerefbox : (Listof (Boxof VAL)) Natural -> (Boxof VAL))
-;; looks for a name in an environment, searching through each frame.
+;; Gets you the box at idx in the frame.
-(define (lookup name env)
+(define (framerefbox frame idx)
-  (cases env
+  (if (null? frame)
-    [(EmptyEnv) (error 'lookup "no binding for ~s" name)]
+      (error 'framerefbox "no binding found for index ~s" idx)
-    [(FrameEnv frame rest)
+      (if (zero? idx)
-     (let ([cell (assq name frame)])
+          (first frame)
-       (if cell
+          (framerefbox (rest frame) (sub1 idx)))))
-         (second cell)
+
-         (lookup name rest)))]))
+(: envrefbox : ENV Natural Natural -> (Boxof VAL))
+;; Gets you the box at (frameidx, keyidx) in an environment.
+(define (envrefbox env frameidx keyidx)
+  (if (null? env)
+      (error 'envrefbox "no binding found for frame index ~s" frameidx)
+      (if (zero? frameidx)
+          (framerefbox (first env) keyidx)
+          (envrefbox (rest env) (sub1 frameidx) keyidx))))
 
 (: unwrap-rktv : VAL -> Any)
 ;; helper for `racket-func->prim-val': unwrap a RktV wrapper in
@@ -154,7 +171,7 @@
          [(RktV v) v]
          [else (error 'racket-func "bad input: ~s" x)]))
 
-(: racket-func->prim-val : Function -> (Boxof VAL))
+(: racket-func->prim-val : Function -> VAL)
 ;; converts a racket function to a primitive evaluator function which
 ;; is a PrimV holding a ((Listof VAL) -> VAL) function.  (the
 ;; resulting function will use the list function as is, and it is the
@@ -162,13 +179,13 @@
 ;; bad number of arguments or bad input types.)
 (define (racket-func->prim-val racket-func)
   (define list-func (make-untyped-list-function racket-func))
-  (box (PrimV (lambda (args)
+  (PrimV (lambda (args)
-                (RktV (list-func (map unwrap-rktv args)))))))
+           (RktV (list-func (map unwrap-rktv args))))))
 
 ;; The global environment has a few primitives:
-(: global-environment : ENV)
+(: global-environment : (Listof (List Symbol VAL)))
 (define global-environment
-  (FrameEnv (list (list '+ (racket-func->prim-val +))
+  (list (list '+ (racket-func->prim-val +))
         (list '- (racket-func->prim-val -))
         (list '* (racket-func->prim-val *))
         (list '/ (racket-func->prim-val /))
@@ -176,9 +193,15 @@
         (list '> (racket-func->prim-val >))
         (list '= (racket-func->prim-val =))
         ;; values
-                  (list 'true  (box (RktV #t)))
+        (list 'true (RktV #t))
-                  (list 'false (box (RktV #f))))
+        (list 'false (RktV #f))))
-            (EmptyEnv)))
+
+(: global-lookup : Symbol -> VAL)
+(define (global-lookup name)
+  (let ([cell (assq name global-environment)])
+    (if cell
+        (second cell)
+        (error 'global-lookup "no binding for ~s" name))))
 
 ;;; ==================================================================
 ;;; Compilation
@@ -208,9 +231,14 @@
   (define (compile-getter expr)
     (cases expr
            [(Id name)
-       (lambda ([env : ENV]) (lookup name env))]
+            (cases (find-index name bin)
+                   [(Some location) (λ ([env : ENV])
+                                      (envrefbox env (first location) (second location)))]
+                   [(None) (if (assq name global-environment)
+                               (λ ([_ : ENV]) (error 'call "rfun can't use global ~s" name))
+                               (error 'compile-get-boxes "no binding for ~s" name))])]
            [else
-       (lambda ([env : ENV])
+            (lambda ([_ : ENV])
               (error 'call "rfun application with a non-identifier ~s"
                      expr))]))
   (unless (unbox compiler-enabled?)
@@ -229,35 +257,49 @@
     (lambda (compiled) (compiled env)))
   (unless (unbox compiler-enabled?)
     (error 'compile "compiler disabled"))
+  (: compile* : TOY -> (ENV -> VAL))
+  (define (compile* expr*) (compile expr* bin))
   (cases expr
          [(Num n) (lambda ([env : ENV]) (RktV n))]
-    [(Id name) (lambda ([env : ENV]) (unbox (lookup name env)))]
+         [(Id name)
+          (cases (find-index name bin)
+                 [(Some location) (λ ([env : ENV]) (unbox (envrefbox env (first location) (second location))))]
+                 [(None) (let ([global-val (global-lookup name)])
+                           (λ ([_ : ENV]) global-val))])]
          [(Set name new)
-     (define compiled-new (compile new))
+          (define compiled-new (compile new bin))
-     (lambda ([env : ENV])
+          (cases (find-index name bin)
-       (set-box! (lookup name env) (compiled-new env))
+                 [(Some location)
+                  (λ ([env : ENV])
+                    (set-box! (envrefbox env (first location) (second location))
+                              (compiled-new env))
                     the-bogus-value)]
+                 [(None)
+                  (let ([_ (global-lookup name)])
+                    (λ ([_ : ENV]) (error 'compile "can't set flobal binding for ~s" name)))])]
          [(Bind names exprs bound-body)
-     (define compiled-exprs (map compile exprs))
+          (define compiled-exprs (map compile* exprs))
-     (define compiled-body  (compile-body bound-body))
+          (define compiled-body (compile-body bound-body (cons names bin)))
           (lambda ([env : ENV])
             (compiled-body
-        (extend names (map (caller env) compiled-exprs) env)))]
+              (extend (map (caller env) compiled-exprs) env)))]
          [(BindRec names exprs bound-body)
-     (define compiled-exprs (map compile exprs))
+          (: ah : (Listof (Listof Symbol)))
-     (define compiled-body  (compile-body bound-body))
+          (define ah (cons names bin))
+          (define compiled-exprs (map (λ ([x : TOY]) (compile x ah)) exprs))
+          (define compiled-body (compile-body bound-body ah))
           (lambda ([env : ENV])
-       (compiled-body (extend-rec names compiled-exprs env)))]
+            (compiled-body (extend-rec compiled-exprs env)))]
          [(Fun names bound-body)
-     (define compiled-body (compile-body bound-body))
+          (define compiled-body (compile-body bound-body (cons names bin)))
           (lambda ([env : ENV]) (FunV names compiled-body env #f))]
          [(RFun names bound-body)
-     (define compiled-body (compile-body bound-body))
+          (define compiled-body (compile-body bound-body (cons names bin)))
           (lambda ([env : ENV]) (FunV names compiled-body env #t))]
          [(Call fun-expr arg-exprs)
-     (define compiled-fun  (compile fun-expr))
+          (define compiled-fun (compile fun-expr bin))
-     (define compiled-args (map compile arg-exprs))
+          (define compiled-args (map compile* arg-exprs))
-     (define compiled-boxes-getter (compile-get-boxes arg-exprs))
+          (define compiled-boxes-getter (compile-get-boxes arg-exprs bin))
           (lambda ([env : ENV])
             (define fval (compiled-fun env))
             ;; delay evaluating the arguments
@@ -266,16 +308,14 @@
                    [(PrimV proc) (proc (arg-vals))]
                    [(FunV names compiled-body fun-env byref?)
                     (compiled-body (if byref?
-                           (raw-extend names
+                                       (cons (compiled-boxes-getter env) fun-env)
-                                       (compiled-boxes-getter env)
+                                       (extend (arg-vals) fun-env)))]
-                                       fun-env)
-                           (extend names (arg-vals) fun-env)))]
                    [else (error 'call "function call with a non-function: ~s"
                                 fval)]))]
          [(If cond-expr then-expr else-expr)
-     (define compiled-cond (compile cond-expr))
+          (define compiled-cond (compile cond-expr bin))
-     (define compiled-then (compile then-expr))
+          (define compiled-then (compile then-expr bin))
-     (define compiled-else (compile else-expr))
+          (define compiled-else (compile else-expr bin))
           (lambda ([env : ENV])
             ((if (cases (compiled-cond env)
                         [(RktV v) v] ; Racket value => use as boolean
@@ -288,9 +328,9 @@
 ;; compiles and runs a TOY program contained in a string
 (define (run str)
   (set-box! compiler-enabled? #t)
-  (let ([compiled (compile (parse str))])
+  (let ([compiled (compile (parse str) '(()))])
     (set-box! compiler-enabled? #f)
-    (let ([result (compiled global-environment)])
+    (let ([result (compiled '())])
       (cases result
              [(RktV v) v]
              [else (error 'run "the program returned a bad value: ~s"
@@ -341,6 +381,8 @@
 ;; assignment tests
 (test (run "{set! {+ x 1} x}") =error> "bad `set!' syntax")
 (test (run "{bind {{x 1}} {set! x {+ x 1}} x}") => 2)
+(test (run "{set! + 1}") =error> "set")
+(test (run "{set! nope 1}") =error> "no binding")
 
 ;; `bindrec' tests
 (test (run "{bindrec {x 6} x}") =error> "bad `bindrec' syntax")
@@ -384,13 +426,19 @@
 (test (run "{{rfun {x} x} {/ 4 0}}") =error> "non-identifier")
 (test (run "{5 {/ 6 0}}") =error> "non-function")
 
+(test (index-of 'k '(a b k c)) => (Some 2))
+(test (index-of 'k '(a b c)) => (None))
+(test (find-index 'k '((a b) (k y) (k z))) => (Some '(1 0)))
+(test (find-index 'a '((a b) (k y))) => (Some '(0 0)))
+(test (find-index 'q '((a b) (k y))) => (None))
+
 ;; test compiler-disabled flag, for complete coverage
 ;; (these tests must use the functions instead of the toplevel `run',
 ;; since there is no way to get this error otherwise, this indicates
 ;; that this error should not occur outside of our code -- it is an
 ;; internal error check)
-(test (compile (Num 1)) =error> "compiler disabled")
+(test (compile (Num 1) '(())) =error> "compiler disabled")
-(test (compile-body (list (Num 1))) =error> "compiler disabled")
+(test (compile-body (list (Num 1)) '(())) =error> "compiler disabled")
-(test (compile-get-boxes (list (Num 1))) =error> "compiler disabled")
+(test (compile-get-boxes (list (Num 1)) '(())) =error> "compiler disabled")
 
 ;;; ==================================================================