Done with compilation.

06-puwae/main.rkt

@@ -30,7 +30,7 @@ POSTT :== PUWAE
   [Sub PUWAE PUWAE]
   [Mul PUWAE PUWAE]
   [Div PUWAE PUWAE]
- ; [Post (Listof POSTT)]
+  [Post (Listof POSTT)]
   [With Symbol PUWAE PUWAE])
 
 (define-type POSTT = (U '+ '- '* '/ PUWAE))
@@ -50,49 +50,27 @@ POSTT :== PUWAE
     [(list '- l r) (Sub (sexpr->puwae l) (sexpr->puwae r))]
     [(list '* l r) (Mul (sexpr->puwae l) (sexpr->puwae r))]
     [(list '/ l r) (Div (sexpr->puwae l) (sexpr->puwae r))]
-    [(list 'post posts ...) (parsepost posts '())]
+    [(list 'post posts ...) (Post (sexpr-list->postts posts))]
     [(list 'with (list (symbol: id) val) bound-body)
      (With id (sexpr->puwae val) (sexpr->puwae bound-body))]
     [_ (error 'sexpr->puwae "malformed expression in ~s" sexpr)]))
 
-(: parsepost : (Sexpr (Listof PUWAE) -> PUWAE))
+(: sexpr->postt : (Sexpr -> POSTT))
-; Parse a post expression into a PUWAE.
+;; Turn a post into POSTT.
-(define (parsepost sexpr glob)
+(define (sexpr->postt sexpr)
   (match sexpr
-    ['() (if (= 1 (length glob)) (first glob) (error 'parsepost "finished with messy glob: ~s" glob))] ; There shouldn't be anything else left in the stack.
+    ['+ '+]
-    [(cons '+ rest) (parsepost rest (parsepost-sum glob))]
+    ['- '-]
-    [(cons '- rest) (parsepost rest (parsepost-sub glob))]
+    ['* '*]
-    [(cons '* rest) (parsepost rest (parsepost-mul glob))]
+    ['/ '/]
-    [(cons '/ rest) (parsepost rest (parsepost-div glob))]
+    [_ (sexpr->puwae sexpr)]))
-    [(cons (symbol: id) rest) (parsepost rest (cons (Id id) glob))] ; Capture non-post symbols (variables).
-    [(cons exp rest) (parsepost rest (cons (sexpr->puwae exp) glob))])) ; Assume anything else must be a PUWAE.
 
-(: glob-swap : Symbol (Listof PUWAE) (PUWAE PUWAE -> PUWAE) -> (Listof PUWAE))
+(: sexpr-list->postts : ((Listof Sexpr) -> (Listof POSTT)))
-; Validates the glob length before swapping with result of globberator.
+(define (sexpr-list->postts sexprs)
-(define (glob-swap operation glob globberator)
+  (match sexprs
-  (if (>= (length glob) 2)
+    ['() '()]
-      (cons (globberator (second glob) (first glob)) (rest (rest glob))) ; Replace the two arguments, while preserving whatever else was on the stack.
+    [(cons token rest)
-      (error 'glob-swap "too few arguments globbed for ~s: ~s" operation glob)))
+     (cons (sexpr->postt token) (sexpr-list->postts rest))]))
-
-(: parsepost-sum : ((Listof PUWAE) -> (Listof PUWAE)))
-; Parse a post sum.
-(define (parsepost-sum glob)
-  (glob-swap 'sum glob Sum))
-
-(: parsepost-mul : ((Listof PUWAE) -> (Listof PUWAE)))
-; Parse a post product.
-(define (parsepost-mul glob)
-  (glob-swap 'mul glob Mul))
-
-(: parsepost-sub : ((Listof PUWAE) -> (Listof PUWAE)))
-; Parse a post subtration.
-(define (parsepost-sub glob)
-  (glob-swap 'sub glob Sub))
-
-(: parsepost-div : ((Listof PUWAE) -> (Listof PUWAE)))
-; Parse a post quotient.
-(define (parsepost-div glob)
-  (glob-swap 'div glob Div))
 
 (: eval : (PUWAE -> Number))
 ;; evaluate to a final number
@@ -104,8 +82,32 @@ POSTT :== PUWAE
     [(Sub l r) (- (eval l) (eval r))]
     [(Mul l r) (* (eval l) (eval r))]
     [(Div l r) (/ (eval l) (eval r))]
+    [(Post postts) (eval-post postts '())]
     [(With id pre-val bound-body) (eval (subst id (Num (eval pre-val)) bound-body))]))
 
+(: post-stack-apply : (Symbol (Number Number -> Number) (Listof Number) -> (Listof Number)))
+(define (post-stack-apply operator operation stack)
+  (if (>= (length stack) 2)
+      (cons (operation (second stack) (first stack)) (rest (rest stack)))
+      (error 'eval-post "Too few arguments for ~s: ~s" operator stack)))
+
+(: eval-post : ((Listof POSTT) (Listof Number) -> Number))
+(define (eval-post postts stack)
+  (match postts
+    ['()
+     (if (= 1 (length stack))
+         (first stack)
+         (error 'eval-post "Finished with messy stack: ~s" stack))]
+    [(cons token rest)
+     (if (symbol? token)
+         (match token
+           ['+ (eval-post rest (post-stack-apply '+ + stack))]
+           ['- (eval-post rest (post-stack-apply '- - stack))]
+           ['* (eval-post rest (post-stack-apply '* * stack))]
+           ['/ (eval-post rest (post-stack-apply '/ / stack))]
+           [_ (error 'eval-post "Bad post operator ~s" token)])
+         (eval-post rest (cons (eval token) stack)))]))
+
 (: subst : (Symbol PUWAE PUWAE -> PUWAE))
 ;; subst all instances of id with val in body
 (define (subst id val body)
@@ -116,6 +118,7 @@ POSTT :== PUWAE
     [(Sub l r) (Sub (subst id val l) (subst id val r))]
     [(Mul l r) (Mul (subst id val l) (subst id val r))]
     [(Div l r) (Div (subst id val l) (subst id val r))]
+    [(Post postts) (Post (subst-postts id val postts))]
     [(With other-id pre-val bound-body)
      (With other-id
            (subst id val pre-val)
@@ -123,6 +126,15 @@ POSTT :== PUWAE
                bound-body
                (subst id val bound-body)))]))
 
+(: subst-postts : (Symbol PUWAE (Listof POSTT) -> (Listof POSTT)))
+(define (subst-postts id val postts)
+  (match postts
+    ['() '()]
+    [(cons token rest)
+     (if (symbol? token)
+         (cons token (subst-postts id val rest))
+         (cons (subst id val token) (subst-postts id val rest)))]))
+
 (: run : String -> Number)
 ;; run the program
 (define (run str)
@@ -139,9 +151,9 @@ POSTT :== PUWAE
 (test (run "{with {x {post 1 3 +}} {post 5 6 + x *}}") => 44)
 (test (run "{post 1 3 + 5 6 + *}") => 44) ; Not 48 :P (5 + 6 ≠ 12).
 
-(test (run "{post 3 +}") =error> "glob-swap: too few arguments globbed for sum: ((Num 3))")
+(test (run "{post 3 +}") =error> "eval-post: Too few arguments for +: (3)")
-(test (run "{post 3 3 3 +}") =error> "parsepost: finished with messy glob: ((Sum (Num 3) (Num 3)) (Num 3))")
+(test (run "{post 3 3 3 +}") =error> "eval-post: Finished with messy stack: (6 3)")
-(test (run "{post 1 2 + 2}") =error> "parsepost: finished with messy glob: ((Num 2) (Sum (Num 1) (Num 2)))")
+(test (run "{post 1 2 + 2}") =error> "eval-post: Finished with messy stack: (2 3)")
 
 (test (run "4") => 4)
 (test (run "{+ 4 {* 2 3}}") => 10)

14-compilation-part-1/main.rkt

@@ -1,6 +1,5 @@
 ;;; ---<<<TOY>>>----------------------------------------------------
 #lang pl
-
 ;;; ----------------------------------------------------------------
 ;;; Syntax
 
@@ -10,6 +9,7 @@
        | { bind {{ <id> <TOY> } ... } <TOY> ... }
        | { bindrec {{ <id> <TOY> } ... } <TOY> ... }
        | { fun { <id> ... } <TOY> ... }
+       | { rfun { <id> ... } <TOY> ... }
        | { <TOY> <TOY> ... }
        | { if <TOY> <TOY> <TOY> }
        | { set! <id> <TOY> }
@@ -22,12 +22,13 @@
              [Bind (Listof Symbol) (Listof TOY) (Listof TOY)]
              [Bindrec (Listof Symbol) (Listof TOY) (Listof TOY)]
              [Fun (Listof Symbol) (Listof TOY)]
+             [Rfun (Listof Symbol) (Listof TOY)]
              [Call TOY (Listof TOY)]
              [If TOY TOY TOY]
              [Set Symbol TOY])
 
 ; Things you can't name things.
-(define BAD_WORDS (list 'bind 'fun 'if 'set! '+ '- '* '/ '= '< '> 'true 'false 'void))
+(define BAD_WORDS (list 'bind 'bindrec 'fun 'rfun 'if 'set! '+ '- '* '/ '= '< '> 'true 'false 'void))
 
 (: unique-list? : (Listof Any) -> Boolean)
 ;; Tests whether a list is unique, guards Bind and Fun values.
@@ -36,6 +37,13 @@
       (and (not (member (first xs) (rest xs)))
            (unique-list? (rest xs)))))
 
+(: no-bad-words? : (Listof Symbol) -> Boolean)
+;; Tests whether a list avoids all bad words.
+(define (no-bad-words? names)
+  (or (null? names)
+      (and (not (member (first names) BAD_WORDS))
+           (no-bad-words? (rest names)))))
+
 (: parse-sexpr : Sexpr -> TOY)
 ;; parses s-expressions into TOYs
 (define (parse-sexpr sexpr)
@@ -45,30 +53,40 @@
     [(symbol: name) (Id name)]
 
     ; Bindrec.
-    [(cons (and binder (or 'bind 'bindrec)) more) ; `binder` bound to 'bind or 'bindrec.
+    [(cons (and binder (or 'bind 'bindrec)) _) ; `binder` bound to 'bind or 'bindrec.
+     ; `_` feels cooler than `more`.
      (match sexpr
        [(list b (list (list (symbol: names) (sexpr: nameds)) ...) body ...)
         (if (not (null? body))
             (if (unique-list? names)
+                (if (no-bad-words? names)
                     ((if (symbol=? b 'bind) Bind Bindrec)
                      names
                      (map parse-sexpr nameds)
-               (last (map parse-sexpr body)))
+                     (map parse-sexpr body))
+                    (error 'parse-sexpr "bad word found in `~s' : ~s" binder names))
                 (error 'parse-sexpr "duplicate `~s' names: ~s" binder names))
             (error 'parse-sexpr "bind expression missing body: ~s" sexpr))]
        [else (error 'parse-sexpr "bad `~s' syntax in ~s" binder sexpr)])]
 
-    ; Function definition.
+    ;
-    [(cons 'fun more)
+    ;
+    ;
+    ; RFun definition.
+    [(cons (and funer (or 'fun 'rfun)) _)
      (match sexpr
-       [(list 'fun (list (symbol: names) ...) body)
+       [(list f (list (symbol: parameters) ...) body ...)
-        (if (unique-list? names)
+        (if (not (null? body))
-            (Fun names (parse-sexpr body))
+            (if (unique-list? parameters)
-            (error 'parse-sexpr "duplicate `fun' names: ~s" names))]
+                (if (no-bad-words? parameters)
-       [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
+                    ((if (symbol=? f 'fun) Fun Rfun) parameters (map parse-sexpr body))
+                    (error 'parse-sexpr "bad words found in function parameter names in ~s" sexpr))
+                (error 'parse-sexpr "bad parameters defined for function in ~s" sexpr))
+            (error 'parse-sexpr "disemobodied function in ~s" sexpr))]
+       [else (error 'parse-sexpr "bad function syntax in ~s" sexpr)])]
 
     ; Conditional.
-    [(cons 'if more)
+    [(cons 'if _)
      (match sexpr
        [(list 'if cond then else)
         (If (parse-sexpr cond)
@@ -77,7 +95,7 @@
        [else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
 
     ; Set!.
-    [(cons 'set! more)
+    [(cons 'set! _)
      (match sexpr
        [(list 'set! (symbol: thing) as)
         (Set thing (parse-sexpr as))])]
@@ -95,9 +113,6 @@
 (define (parse str)
   (parse-sexpr (string->sexpr str)))
 
-;;; ----------------------------------------------------------------
-;;; Values and environments
-
 (define-type ENV
              [EmptyEnv]
              [FrameEnv FRAME ENV])
@@ -107,7 +122,8 @@
 
 (define-type VAL
              [RktV Any]
-  [FunV  (Listof Symbol) TOY ENV]
+             ; Parameters, compiled body, whether it's an Rfun, environment.
+             [FunV (Listof Symbol) (ENV -> VAL) Boolean ENV]
              [PrimV ((Listof VAL) -> VAL)]
              [VoidV])
 
@@ -125,16 +141,14 @@
                 env)
       (error 'extend "arity mismatch for names: ~s" names)))
 
-(: extend-rec : (Listof Symbol) (Listof TOY) ENV -> ENV)
+(: extend-rec : (Listof Symbol) (Listof (ENV -> VAL)) ENV -> ENV)
-(define (extend-rec names vals env)
+(define (extend-rec names compiled-vals env)
-  (define newenv (extend names (map (lambda (_) (VoidV)) vals) env))
+  (define newenv (extend names (map (lambda (_) (VoidV)) compiled-vals) env))
-  (for-each (lambda ([name : Symbol] [val : TOY])
+  (for-each (lambda ([name : Symbol] [compiled-val : (ENV -> VAL)])
-              (set-box! (lookup name newenv) (eval val newenv)))
+              (set-box! (lookup name newenv) (compiled-val newenv)))
-            names vals)
+            names compiled-vals)
   newenv)
 
-
-
 (: lookup : Symbol ENV -> (Boxof VAL))
 ;; lookup a symbol in an environment, frame by frame,
 ;; return its value or throw an error if it isn't bound
@@ -182,54 +196,172 @@
                   (list 'void (box (VoidV))))
             (EmptyEnv)))
 
-;;; ----------------------------------------------------------------
+(: compiler-enabled? : (Boxof Boolean))
-;;; Evaluation
+(define compiler-enabled? (box #f))
 
-(: eval : TOY ENV -> VAL)
+(: ensure-compiler-enabled! : Symbol -> Void)
-;; evaluates TOY expressions
+(define (ensure-compiler-enabled! who)
-(define (eval expr env)
+  (if (unbox compiler-enabled?)
-  ;; convenient helper
+      (void)
-  (: eval* : TOY -> VAL)
+      (error who "compiler is not enabled")))
-  (define (eval* expr) (eval expr env))
+
+(: run-compiled-body : (Listof (ENV -> VAL)) ENV -> VAL)
+; Compile a body of expressions.
+(define (run-compiled-body compiled env)
+  (if (null? compiled)
+      (error 'compile "empty body")
+      (if (null? (rest compiled))
+          ((first compiled) env)
+          (let ([_ ((first compiled) env)]) ; We've side effects in this language.
+            (run-compiled-body (rest compiled) env)))))
+
+(: compile-body : (Listof TOY) -> (ENV -> VAL))
+;; Compile a sequence of body expressions into runtime sequencing code.
+(define (compile-body body)
+  (ensure-compiler-enabled! 'compile-body)
+  (define compiled-body (map compile body))
+  (lambda ([env : ENV])
+    (run-compiled-body compiled-body env)))
+
+; Convenient helper for running compiled code.
+(: caller : ENV -> (ENV -> VAL) -> VAL)
+(define (caller env)
+  (lambda ([compiled : (ENV -> VAL)]) (compiled env)))
+
+(: compile : TOY -> (ENV -> VAL))
+;; compileuates TOY expressions.
+(define (compile expr)
+  (ensure-compiler-enabled! 'compile)
   (cases expr
-    [(Num n)   (RktV n)]
+         [(Num n) (λ ([_ : ENV]) (RktV n))]
-    [(Id name) (unbox (lookup name env))]
+         [(Id name) (λ ([env : ENV]) (unbox (lookup name env)))]
-    [(Bind names exprs bound-body)
+         [(Bind names exprs body)
-     (eval bound-body (extend names (map eval* exprs) env))]
+          (define compiled-exprs (map compile exprs))
-    [(Bindrec names exprs bound-body)
+          (define compiled-body (compile-body body))
-     (eval bound-body (extend-rec names exprs env))]
+          (λ ([env : ENV])
-    [(Fun names bound-body)
+            (compiled-body
-     (FunV names bound-body env)]
+              (extend names
+                      (map (caller env) compiled-exprs)
+                      env)))]
+         [(Bindrec names exprs body)
+          (define compiled-exprs (map compile exprs))
+          (define compiled-body (compile-body body))
+          (λ ([env : ENV])
+            (compiled-body (extend-rec names compiled-exprs env)))]
+         [(Fun names body)
+          (define compiled-body (compile-body body))
+          (λ ([env : ENV]) (FunV names compiled-body #f env))]
+         [(Rfun names body)
+          (define compiled-body (compile-body body))
+          (λ ([env : ENV]) (FunV names compiled-body #t env))]
          [(Call fun-expr arg-exprs)
-     (let ([fval (eval* fun-expr)]
+          (define compiled-fun (compile fun-expr))
-           [arg-vals (map eval* arg-exprs)])
+          (define compiled-args (map compile arg-exprs))
+          (define compiled-get-boxes (compile-get-boxes arg-exprs))
+          (λ ([env : ENV])
+            (let ([fval (compiled-fun env)]
+                  [arg-vals-thunk
+                   (lambda ()
+                     (map (caller env) compiled-args))]) ; THunk.
               (cases fval
-         [(PrimV proc) (proc arg-vals)]
+                     [(PrimV proc) (proc (arg-vals-thunk))]
-         [(FunV names body fun-env)
+                     [(FunV names body ref? fun-env)
-          (eval body (extend names arg-vals fun-env))]
+                      (if ref?
-         [else (error 'eval "function call with a non-function: ~s"
+                          (compile-rfun names compiled-get-boxes body env fun-env)
-                      fval)]))]
+                          (body (extend names (arg-vals-thunk) fun-env)))]
+                     [else (error 'compile "function call with a non-function: ~s"
+                                  fval)])))]
          [(If cond-expr then-expr else-expr)
-     (eval* (if (cases (eval* cond-expr)
+          (define compiled-cond (compile cond-expr))
+          (define compiled-then (compile then-expr))
+          (define compiled-else (compile else-expr))
+          (λ ([env : ENV])
+            (if (cases (compiled-cond env)
                        [(RktV v) v] ; Racket value => use as boolean
                        [else #t]) ; other values are always true
-                then-expr
+                (compiled-then env)
-                else-expr))]
+                (compiled-else env)))]
          [(Set thing as)
-     (set-box! (lookup thing env) (eval* as)) ; We are not a lazy language.
+          (define compiled-as (compile as))
-     (VoidV)]))
+          (λ ([env : ENV])
+            (set-box! (lookup thing env) (compiled-as env))
+            (VoidV))]))
+
+(: compile-rfun : (Listof Symbol) (ENV -> (Listof (Boxof VAL))) (ENV -> VAL) ENV ENV -> VAL)
+; Compile an RFun.
+(define (compile-rfun params get-boxes body callerenv calleeenv)
+  (body (raw-extend params (get-boxes callerenv) calleeenv)))
+
+(: compile-get-boxes : (Listof TOY) -> (ENV -> (Listof (Boxof VAL))))
+; Utility for applying rfun.
+(define (compile-get-boxes exprs)
+  (ensure-compiler-enabled! 'compile-get-boxes)
+  (: compile-getter : TOY -> (ENV -> (Boxof VAL)))
+  (define (compile-getter expr)
+    (cases expr
+           [(Id name) (lambda ([env : ENV]) (lookup name env))]
+           [else
+            (lambda ([_ : ENV]) (error 'compile-get-boxes "non-identifier"))]))
+  (let ([getters (map compile-getter exprs)])
+    (lambda ([env : ENV])
+      (map (lambda ([getter : (ENV -> (Boxof VAL))])
+             (getter env))
+           getters))))
 
 (: run : String -> Any)
 ;; evaluate a TOY program contained in a string
 (define (run str)
-  (let ([result (eval (parse str) global-environment)])
+  (define parsed (parse str))
+  (set-box! compiler-enabled? #t)
+  (define compiled (compile parsed))
+  (set-box! compiler-enabled? #f)
+  (let ([result (compiled global-environment)])
     (cases result
            [(RktV v) v]
            [else (error 'run "evaluation returned a bad value: ~s"
                         result)])))
 
-;;; ----------------------------------------------------------------
+(test (run "{{rfun {x} x} {/ 4 0}}") =error> "non-identifier")
-;;; Tests
+(test (run "{5 {/ 6 0}}") =error> "non-function")
+(test (run "
+{bind
+    {
+        {swap!
+            {rfun {x y}
+                {bind {{tmp x}}
+                    {set! x y}
+                    {set! y tmp}
+                }
+            }
+        }
+
+        {a 1}
+
+        {b 2}
+    }
+
+    {swap! a b}
+
+    {+ a {* 10 b}}
+}") => 12)
+
+(test (run "{bind {{make-counter
+{fun {}
+{bind {{c 0}}
+{fun {}
+{set! c {+ 1 c}}
+c}}}}}
+{bind {{c1 {make-counter}}
+{c2 {make-counter}}}
+{* {c1} {c1} {c2} {c1}}}}")
+
+      => 6)
+(test (run "{bindrec {{foo {fun {}
+
+{set! foo {fun {} 2}}
+1}}}
+{+ {foo} {* 10 {foo}}}}")
+      => 21)
 
 (test (run "{bindrec {{fact {fun {n}
 {if {= 0 n}
@@ -237,7 +369,7 @@
 {* n {fact {- n 1}}}}}}}
 
 {fact 5}}")
-=> 120)
+      => 120)
 
 (test (run "
 {bind {{x 10}}
@@ -274,11 +406,11 @@
 
 ;; More tests for complete coverage
 (test (run "{bind x 5 x}") =error> "bad `bind' syntax")
-(test (run "{fun x x}")         =error> "bad `fun' syntax")
+(test (run "{fun x x}") =error> "parse-sexpr: bad function syntax in (fun x x)")
 (test (run "{if x}") =error> "bad `if' syntax")
 (test (run "{}") =error> "bad syntax")
-(test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names")
+(test (run "{bind {{x 5} {x 5}} x}") =error> "parse-sexpr: duplicate `bind' names: (x x)")
-(test (run "{fun {x x} x}")     =error> "duplicate*fun*names")
+(test (run "{fun {x x} x}") =error> "parse-sexpr: bad parameters defined for function in (fun (x x) x)")
 (test (run "{+ x 1}") =error> "no binding for")
 (test (run "{+ 1 {fun {x} x}}") =error> "bad input")
 (test (run "{+ 1 {fun {x} x}}") =error> "bad input")
@@ -288,3 +420,10 @@
 (test (run "{if {< 5 4} 6 7}") => 7)
 (test (run "{if + 6 7}") => 6)
 (test (run "{fun {x} x}") =error> "returned a bad value")
+
+(test (compile (Num 1)) =error> "compiler is not enabled")
+(test (compile-body (list (Num 1))) =error> "compiler is not enabled")
+(test (compile-get-boxes (list (Id 'x))) =error> "compiler is not enabled")
+
+(test (run "{bind {{if 5}} if}") =error> "parse-sexpr: bad word found in `bind' : (if)")
+(test (run "{fun {if} if}") =error> "parse-sexpr: bad words found in function parameter names in (fun (if) if)")