152 lines
4.7 KiB
Racket
152 lines
4.7 KiB
Racket
#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) |