rendered paste body;;; ==================================================================
;;; Syntax
#| The BNF:
<TOY> ::= <num>
| <id>
| { bind {{ <id> <TOY> }* } <TOY>}
| { bindrec {{ <id> <TOY> }* } <TOY>}
| { fun { <id>* } <TOY> }
| { if <TOY> <TOY> <TOY> }
| { <TOY> <TOY>* }
|#
;; A matching abstract syntax tree datatype:
(define-type TOY
[Num (n number?)]
[Id (name symbol?)]
[Bind (names unique-names?) (exprs (list-of TOY?)) (body TOY?)]
[Bindrec (names unique-names?) (exprs (list-of TOY?)) (body TOY?)]
[Fun (names unique-names?) (body TOY?)]
[Call (fun-expr TOY?) (arg-exprs (list-of TOY?))]
[If (cond-expr TOY?) (then-expr TOY?) (else-expr TOY?)])
;; unique-list? : list -> bool
;; Tests whether a list is unique, used to make `unique-names?' below.
(define (unique-list? xs)
(or (null? xs)
(and (not (member (first xs) (rest xs)))
(unique-list? (rest xs)))))
;; unique-names? : any -> bool
;; A predicate that is used to specify a type of unique symbol lists.
(define unique-names? (intersect-of (list-of symbol?) unique-list?))
;; parse-sexpr : s-expr -> TOY
(define (parse-sexpr sexpr)
(cond
[(number? sexpr) (Num sexpr)]
[(symbol? sexpr) (Id sexpr)]
[(or (not (list? sexpr)) (null? sexpr))
(error 'parse-sexpr "Bad syntax: ~s" sexpr)]
[else (case (first sexpr)
[(bind)
(if (and (= 3 (length sexpr))
(list? (second sexpr))
(andmap (lambda (x)
(and (list? x) (= 2 (length x))))
(second sexpr)))
(Bind (map first (second sexpr))
(map (compose parse-sexpr second) (second sexpr))
(parse-sexpr (third sexpr)))
(error 'parse-sexpr "Bad `bind' syntax: ~s" sexpr))]
[(bind bindrec)
(if (and (= 3 (length sexpr))
(list? (second sexpr))
(andmap (lambda (x)
(and (list? x) (= 2 (length x))))
(second sexpr)))
(Bindrec (map first (second sexpr))
(map (compose parse-sexpr second) (second sexpr))
(parse-sexpr (third sexpr)))
(error 'parse-sexpr "Bad `bindrec' syntax: ~s" sexpr))]
[(fun)
(if (and (= 3 (length sexpr)) (list? (second sexpr)))
(Fun (second sexpr) (parse-sexpr (third sexpr)))
(error 'parse-sexpr "Bad `fun' syntax: ~s" sexpr))]
[(if)
(if (= 4 (length sexpr))
(If (parse-sexpr (second sexpr))
(parse-sexpr (third sexpr))
(parse-sexpr (fourth sexpr)))
(error 'parse-sexpr "Bad `if' syntax: ~s" sexpr))]
[else ; other lists are applications
(Call (parse-sexpr (first sexpr))
(map parse-sexpr (rest sexpr)))])]))
;; parse : string -> TOY
;; Parses a string containing an TOY expression to a TOY AST.
(define (parse str)
(parse-sexpr (string->sexpr str)))
;;; ==================================================================
;;; Values and environments
(define-type ENV
[EmptyEnv]
[FrameEnv (frame frame?) (rest ENV?)])
(define-type VAL
[ScmV (x any?)]
[FunV (names unique-names?) (body TOY?) (env ENV?)]
[PrimV (prim procedure?)])
;; a frame is an association list of names and values.
(define frame?
(list-of (lambda (x)
(and (list? x)
(= 2 (length x))
(symbol? (first x))
(VAL? (second x))))))
;; extend : (list-of symbol) (list-of VAL) ENV -> ENV
;; extends an environment with a new frame.
(define (extend names values env)
(if (= (length names) (length values))
(FrameEnv (map list names values) env)
(error 'extend "arity mismatch for names ~s" names)))
;; lookup : symbol ENV -> (box-of VAL)
;; looks a name in an environment, searching through each frame.
(define (lookup name env)
(cases env
[(EmptyEnv) (error 'lookup "no binding for ~s" name)]
[(FrameEnv frame rest)
(let ([cell (assq name frame)])
(if cell
(box (second cell))
(lookup name rest)))]))
;; scheme-func->prim-val : (any ... -> any) -> TOY-val
;; converts a scheme function to a primitive evaluator
;; function which is a PrimV holding a ((list-of TOY-val) -> TOY-val)
;; procedure. (the result procedure doesn't check for types and
;; arity.)
(define (scheme-func->prim-val scheme-func)
(PrimV (lambda (args)
(let ([args (map (lambda (a)
(cases a
[(ScmV x) x]
[else (error 'scheme-func
"bad input: ~s" a)]))
args)])
(ScmV (apply scheme-func args))))))
;; The global environment has a few primitives:
(define global-environment
(FrameEnv (list (list '+ (scheme-func->prim-val +))
(list '- (scheme-func->prim-val -))
(list '* (scheme-func->prim-val *))
(list '/ (scheme-func->prim-val /))
(list '< (scheme-func->prim-val <))
(list '> (scheme-func->prim-val >))
(list '= (scheme-func->prim-val =))
;; values
(list 'true (ScmV #t))
(list 'false (ScmV #f)))
(EmptyEnv)))
;;; ==================================================================
;;; Evaluation
;; eval : TOY env -> VAL
;; evaluates TOY expressions.
(define (eval expr env)
(cases expr
[(Num n) (ScmV n)]
[(Id v) (unbox (lookup v env))]
[(Bind names exprs bound-body)
(eval bound-body
(extend names
(map (lambda (e) (eval e env)) exprs)
env))]
[(Bindrec names exprs bound-body)
(eval bound-body
(extend names
(map (lambda (e) (eval e env)) exprs)
env))]
[(Fun names bound-body)
(FunV names bound-body env)]
[(Call fun-expr arg-exprs)
(let ([fval (eval fun-expr env)]
[arg-vals (map (lambda (e) (eval e env)) arg-exprs)])
(cases fval
[(PrimV proc) (proc arg-vals)]
[(FunV names body fun-env)
(eval body (extend names arg-vals fun-env))]
[else (error 'eval "`call' expects a function, got: ~s"
fval)]))]
[(If cond-expr then-expr else-expr)
(eval (if (cases (eval cond-expr env)
[(ScmV v) v] ; Scheme value => use as boolean
[else #t]) ; other values are always true
then-expr
else-expr)
env)]))
;; run : string -> number
;; evaluate a TOY program contained in a string
(define (run str)
(let ([result (eval (parse str) global-environment)])
(cases result
[(ScmV n) n]
[else (error 'run
"evaluation returned a non-number: ~s" result)])))
;;; ==================================================================
;;; Tests
(test 5 (run "{{fun {x} {+ x 1}} 4}"))
(test 4 (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}"))
(test 7 (run "{bind {{add3 {fun {x} {+ x 3}}}
{add1 {fun {x} {+ x 1}}}}
{bind {{x 3}} {add1 {add3 x}}}}"))
(test 124
(run "{bind {{identity {fun {x} x}}
{foo {fun {x} {+ x 1}}}}
{{identity foo} 123}}"))
(test 7
(run "{bind {{x 3}}
{bind {{f {fun {y} {+ x y}}}}
{bind {{x 5}}
{f 4}}}}"))
(test 124
(run "{{{fun {x} {x 1}}
{fun {x} {fun {y} {+ x y}}}}
123}"))
(test 120
(run "{bindrec {{fact {fun {n}
{if {= 0 n}
1
{* n {fact {- n 1}}}}}}}
{fact 5}}"))
;;; ==================================================================