More.

09-tidbit/main.rkt

@@ -0,0 +1,167 @@
+#lang pl
+
+#|
+The grammar:
+  <TIDBIT> ::= <num>
+            | { + <TIDBIT> <TIDBIT> }
+            | { - <TIDBIT> <TIDBIT> }
+            | { * <TIDBIT> <TIDBIT> }
+            | { / <TIDBIT> <TIDBIT> }
+            | { with { <id> <TIDBIT> } <TIDBIT> }
+            | <id>
+            | { fun { <id> } <TIDBIT> }
+            | { call <TIDBIT> <TIDBIT> }
+|#
+
+(define-type TIDBIT
+             [Num Number]
+             [Add TIDBIT TIDBIT]
+             [Sub TIDBIT TIDBIT]
+             [Mul TIDBIT TIDBIT]
+             [Div TIDBIT TIDBIT]
+             [Id Symbol]
+             [With Symbol TIDBIT TIDBIT]
+             [Fun Symbol TIDBIT]
+             [Call TIDBIT TIDBIT])
+
+(define-type Idx = Integer)
+
+(define-type CORE
+             [CNum Number]
+             [CAdd CORE CORE]
+             [CSub CORE CORE]
+             [CMul CORE CORE]
+             [CDiv CORE CORE]
+             [CIdx Idx]
+             [CWith CORE CORE]
+             [CFun CORE]
+             [CCall CORE CORE])
+
+(define-type BINDING-DEPTH = (Symbol -> Number))
+
+(: empty-depth : BINDING-DEPTH)
+(define (empty-depth s) (error 'empty-depth "empty depth"))
+
+(: binding-encountered : BINDING-DEPTH Symbol -> BINDING-DEPTH)
+(define (binding-encountered bd id))
+
+(: parse-sexpr : Sexpr -> TIDBIT)
+; Parses Sexprs into TIDBITs.
+(define (parse-sexpr sexpr)
+  (match sexpr
+    [(number: n) (Num n)]
+    [(symbol: name) (Id name)]
+    [(cons 'with more)
+     (match sexpr
+       [(list 'with (list (symbol: name) named) body)
+        (With name (parse-sexpr named) (parse-sexpr body))]
+       [else (error 'parse-sexpr "bad `with' syntax in ~s" sexpr)])]
+    [(cons 'fun more)
+     (match sexpr
+       [(list 'fun (list (symbol: name)) body) (Fun name (parse-sexpr body))]
+       [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
+    [(list '+ lhs rhs) (Add (parse-sexpr lhs) (parse-sexpr rhs))]
+    [(list '- lhs rhs) (Sub (parse-sexpr lhs) (parse-sexpr rhs))]
+    [(list '* lhs rhs) (Mul (parse-sexpr lhs) (parse-sexpr rhs))]
+    [(list '/ lhs rhs) (Div (parse-sexpr lhs) (parse-sexpr rhs))]
+    [(list 'call fun arg) (Call (parse-sexpr fun) (parse-sexpr arg))]
+    [(list fun 'of arg) (Call (parse-sexpr fun) (parse-sexpr arg))]
+    [else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))
+
+(: parse : String -> TIDBIT)
+;; parses a string containing a TIDBIT expression to a TIDBIT AST
+(define (parse str)
+  (parse-sexpr (string->sexpr str)))
+
+;; Types for environments, values, and a lookup function
+(define-type VAL
+  [NumV Number]
+  [FunV CORE ENV])
+
+(define-type ENV = (Listof VAL))
+
+
+(: NumV->number : VAL -> Number)
+;; convert a TIDBIT runtime numeric value to a Racket one
+(define (NumV->number val)
+  (cases val
+    [(NumV n) n]
+    [else (error 'arith-op "expected a number, got: ~s" val)]))
+
+(: arith-op : (Number Number -> Number) VAL VAL -> VAL)
+;; gets a Racket numeric binary operator, and uses it within a NumV
+;; wrapper
+(define (arith-op op val1 val2)
+  (NumV (op (NumV->number val1) (NumV->number val2))))
+
+(: eval : CORE ENV -> VAL)
+;; evaluates CORE expressions by reducing them to values
+(define (eval expr env)
+  (cases expr
+    [(CNum n) (NumV n)]
+    [(CAdd l r) (arith-op + (eval l env) (eval r env))]
+    [(CSub l r) (arith-op - (eval l env) (eval r env))]
+    [(CMul l r) (arith-op * (eval l env) (eval r env))]
+    [(CDiv l r) (arith-op / (eval l env) (eval r env))]
+    [(CWith bound-val bound-body)
+     (eval bound-body (cons (eval bound-val env) env))]
+    [(CIdx n) (list-ref env n)]
+    [(CFun body)
+     (FunV body env)]
+    [(CCall fun-expr arg-expr)
+     (let ([fval (eval fun-expr env)])
+       (cases fval
+         [(FunV body f-env)
+          (eval body (cons (eval arg-expr env) f-env))]
+         [else (error 'eval "`call' expects a function, got: ~s"
+                            fval)]))]))
+
+#|
+(: run : String -> Number)
+;; evaluate a TIDBIT program contained in a string
+(define (run str)
+  (let ([result (eval (parse str) (EmptyEnv))])
+    (cases result
+      [(NumV n) n]
+      [else (error 'run "evaluation returned a non-number: ~s"
+                   result)])))
+
+(test (run "{with fh dhd dhdh lja}") =error> "parse-sexpr: bad `with' syntax in (with fh dhd dhdh lja)")
+(test (run "{fun fh dhd dhdh lja}") =error> "parse-sexpr: bad `fun' syntax in (fun fh dhd dhdh lja)")
+(test (run "{}") =error> "parse-sexpr: bad syntax in ()")
+(test (run "{asdf of 2}") =error> "lookup: no binding for asdf")
+(test (run "{+ 1 {fun {x} x}}") =error> "arith-op: expected a number, got: (FunV x (Id x) (EmptyEnv))")
+(test (run "{1 of 1}") =error> "eval: `call' expects a function, got: (NumV 1)")
+(test (run "{fun {x} x}") =error> "run: evaluation returned a non-number: (FunV x (Id x) (EmptyEnv))")
+
+(test (run "{{fun {x} {+ x 1}} of 4}")
+      => 5)
+(test (run "{with {add3 {fun {x} {+ x 3}}}
+              {add3 of 1}}")
+      => 4)
+(test (run "{with {add3 {fun {x} {+ x 3}}}
+              {with {add1 {fun {x} {+ x 1}}}
+                {with {x 3}
+                  {add1 of {add3 of x}}}}}")
+      => 7)
+(test (run "{with {identity {fun {x} x}}
+              {with {foo {fun {x} {+ x 1}}}
+                {{identity of foo} of 123}}}")
+      => 124)
+(test (run "{with {x 3}
+              {with {f {fun {y} {+ x y}}}
+                {with {x 5}
+                  {f of 4}}}}")
+      => 7)
+(test (run "{call {with {x 3}
+                    {fun {y} {+ x y}}}
+                  4}")
+      => 7)
+(test (run "{with {f {with {x 3} {fun {y} {+ x y}}}}
+              {with {x 100}
+                {f of 4}}}")
+      => 7)
+(test (run "{call {call {fun {x} {x of 1}}
+                        {fun {x} {fun {y} {+ x y}}}}
+                  123}")
+      => 124)|#