Close.

13-bang/main.rkt

@@ -10,6 +10,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,6 +23,7 @@
   [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])
@@ -53,19 +55,21 @@
                 ((if (symbol=? b 'bind) Bind Bindrec)
                  names
                  (map parse-sexpr nameds)
-               (last (map parse-sexpr body)))
+                 (map parse-sexpr body))
                 (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)
+    ; Reference function definition.
+    [(cons (and funer (or 'fun 'rfun)) more)
      (match sexpr
-       [(list 'fun (list (symbol: names) ...) body)
-        (if (unique-list? names)
-            (Fun names (parse-sexpr body))
-            (error 'parse-sexpr "duplicate `fun' names: ~s" names))]
-       [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
+       [(list f (list (symbol: parameters) ...) body ...)
+        (if (not (null? body))
+            (if (unique-list? parameters)
+                ((if (symbol=? f 'fun) Fun Rfun) parameters (map parse-sexpr body))
+                (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)
@@ -107,7 +111,8 @@
 
 (define-type VAL
   [RktV  Any]
-  [FunV  (Listof Symbol) TOY ENV]
+  ; Parameters, body expressions, whether it's an Rfun, environment.
+  [FunV  (Listof Symbol) (Listof TOY) Boolean ENV]
   [PrimV ((Listof VAL) -> VAL)]
   [VoidV])
 
@@ -133,8 +138,6 @@
             names 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
@@ -195,18 +198,20 @@
     [(Num n)   (RktV n)]
     [(Id name) (unbox (lookup name env))]
     [(Bind names exprs bound-body)
-     (eval bound-body (extend names (map eval* exprs) env))]
+     (eval-body bound-body (extend names (map eval* exprs) env))]
     [(Bindrec names exprs bound-body)
-     (eval bound-body (extend-rec names exprs env))]
+     (eval-body bound-body (extend-rec names exprs env))]
     [(Fun names bound-body)
-     (FunV names bound-body env)]
+     (FunV names bound-body #f env)]
+    [(Rfun names bound-body)
+     (FunV names bound-body #t env)]
     [(Call fun-expr arg-exprs)
      (let ([fval (eval* fun-expr)]
            [arg-vals (map eval* arg-exprs)])
        (cases fval
          [(PrimV proc) (proc arg-vals)]
-         [(FunV names body fun-env)
-          (eval body (extend names arg-vals fun-env))]
+         [(FunV names body ref? fun-env)
+          (if ref? (eval-rfun names arg-exprs body fun-env) (eval-body body (extend names arg-vals fun-env)))]
          [else (error 'eval "function call with a non-function: ~s"
                       fval)]))]
     [(If cond-expr then-expr else-expr)
@@ -219,6 +224,25 @@
      (set-box! (lookup thing env) (eval* as)) ; We are not a lazy language.
      (VoidV)]))
 
+(: eval-rfun : (Listof Symbol) (Listof TOY) (Listof TOY) ENV -> VAL)
+(define (eval-rfun params args body env)
+  (eval-body body (raw-extend params (get-boxes args env) env)))
+
+(: get-boxes : (Listof TOY) ENV -> (Listof (Boxof VAL)))
+(define (get-boxes ids env)
+  (: boxes (Listof (Boxof VAL)))
+  (define boxes '())
+  (for-each (lambda ([id : TOY])
+              (cases id
+                [(Id name) (set! boxes (cons (lookup name env) boxes))]
+                [else (error 'get-boxes "non-identifier")])) ids)
+  boxes)
+
+(: eval-body : (Listof TOY) ENV -> VAL)
+; Evaluates a body of expressions, returning the result of the last.
+(define (eval-body exprs env)
+  (list-ref (map (lambda ([expr : TOY]) (eval expr env)) exprs) (sub1 (length exprs))))
+
 (: run : String -> Any)
 ;; evaluate a TOY program contained in a string
 (define (run str)
@@ -230,6 +254,46 @@
 
 ;;; ----------------------------------------------------------------
 ;;; Tests
+(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 +301,7 @@
 {* n {fact {- n 1}}}}}}}
 
 {fact 5}}")
-=> 120)
+      => 120)
 
 (test (run "
 {bind {{x 10}}