More.

2026-01-12 23:52:50 -05:00
parent 5268b8a155
commit ef2f5f64dc
2 changed files with 319 additions and 0 deletions
@@ -0,0 +1,152 @@
+#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])
+
+(: parse-sexpr : Sexpr -> TIDBIT)
+;; parses s-expressions 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))]
+    [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 ENV
+  [EmptyEnv]
+  [Extend Symbol VAL ENV])
+
+(define-type VAL
+  [NumV Number]
+  [FunV Symbol TIDBIT ENV])
+
+(: lookup : Symbol ENV -> VAL)
+;; lookup a symbol in an environment, return its value or throw an
+;; error if it isn't bound
+(define (lookup name env)
+  (cases env
+    [(EmptyEnv) (error 'lookup "no binding for ~s" name)]
+    [(Extend id val rest-env)
+     (if (eq? id name) val (lookup name rest-env))]))
+
+(: 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 : TIDBIT ENV -> VAL)
+;; evaluates TIDBIT expressions by reducing them to values
+(define (eval expr env)
+  (cases expr
+    [(Num n) (NumV n)]
+    [(Add l r) (arith-op + (eval l env) (eval r env))]
+    [(Sub l r) (arith-op - (eval l env) (eval r env))]
+    [(Mul l r) (arith-op * (eval l env) (eval r env))]
+    [(Div l r) (arith-op / (eval l env) (eval r env))]
+    [(With bound-id named-expr bound-body)
+     (eval bound-body
+           (Extend bound-id (eval named-expr env) env))]
+    [(Id name) (lookup name env)]
+    [(Fun bound-id bound-body)
+     (FunV bound-id bound-body env)]
+    [(Call fun-expr arg-expr)
+     (let ([fval (eval fun-expr env)])
+       (cases fval
+         [(FunV bound-id bound-body f-env)
+          (eval bound-body
+                (Extend bound-id (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)])))
+
+;; tests
+(test (run "{call {fun {x} {+ x 1}} 4}")
+      => 5)
+(test (run "{with {add3 {fun {x} {+ x 3}}}
+              {call add3 1}}")
+      => 4)
+(test (run "{with {add3 {fun {x} {+ x 3}}}
+              {with {add1 {fun {x} {+ x 1}}}
+                {with {x 3}
+                  {call add1 {call add3 x}}}}}")
+      => 7)
+(test (run "{with {identity {fun {x} x}}
+              {with {foo {fun {x} {+ x 1}}}
+                {call {call identity foo} 123}}}")
+      => 124)
+(test (run "{with {x 3}
+              {with {f {fun {y} {+ x y}}}
+                {with {x 5}
+                  {call f 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}
+                {call f 4}}}")
+      => 7)
+(test (run "{call {call {fun {x} {call x 1}}
+                        {fun {x} {fun {y} {+ x y}}}}
+                  123}")
+      => 124)