Added Bang! and Y++.
This commit is contained in:
@@ -0,0 +1,223 @@
|
||||
;;; ---<<<TOY>>>----------------------------------------------------
|
||||
#lang pl
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Syntax
|
||||
|
||||
#| The AST:
|
||||
<TOY> ::= <num>
|
||||
| <id>
|
||||
| { bind {{ <id> <TOY> } ... } <TOY> }
|
||||
| { fun { <id> ... } <TOY> }
|
||||
| { if <TOY> <TOY> <TOY> }
|
||||
| { <TOY> <TOY> ... }
|
||||
|#
|
||||
|
||||
;; A matching abstract syntax tree datatype:
|
||||
(define-type TOY
|
||||
[Num Number]
|
||||
[Id Symbol]
|
||||
[Bind (Listof Symbol) (Listof TOY) TOY]
|
||||
[Fun (Listof Symbol) TOY]
|
||||
[Call TOY (Listof TOY)]
|
||||
[If TOY TOY TOY])
|
||||
|
||||
(: unique-list? : (Listof Any) -> Boolean)
|
||||
;; Tests whether a list is unique, guards Bind and Fun values.
|
||||
(define (unique-list? xs)
|
||||
(or (null? xs)
|
||||
(and (not (member (first xs) (rest xs)))
|
||||
(unique-list? (rest xs)))))
|
||||
|
||||
(: parse-sexpr : Sexpr -> TOY)
|
||||
;; parses s-expressions into TOYs
|
||||
(define (parse-sexpr sexpr)
|
||||
(match sexpr
|
||||
[(number: n) (Num n)]
|
||||
[(symbol: name) (Id name)]
|
||||
[(cons 'bind more)
|
||||
(match sexpr
|
||||
[(list 'bind (list (list (symbol: names) (sexpr: nameds))
|
||||
...)
|
||||
body)
|
||||
(if (unique-list? names)
|
||||
(Bind names (map parse-sexpr nameds) (parse-sexpr body))
|
||||
(error 'parse-sexpr "duplicate `bind' names: ~s" names))]
|
||||
[else (error 'parse-sexpr "bad `bind' syntax in ~s" sexpr)])]
|
||||
[(cons 'fun 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)])]
|
||||
[(cons 'if more)
|
||||
(match sexpr
|
||||
[(list 'if cond then else)
|
||||
(If (parse-sexpr cond)
|
||||
(parse-sexpr then)
|
||||
(parse-sexpr else))]
|
||||
[else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
|
||||
[(list fun args ...) ; other lists are applications
|
||||
(Call (parse-sexpr fun)
|
||||
(map parse-sexpr args))]
|
||||
[else (error 'parse-sexpr "bad syntax in ~s" 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 ENV])
|
||||
|
||||
;; a frame is an association list of names and values.
|
||||
(define-type FRAME = (Listof (List Symbol VAL)))
|
||||
|
||||
(define-type VAL
|
||||
[RktV Any]
|
||||
[FunV (Listof Symbol) TOY ENV]
|
||||
[PrimV ((Listof VAL) -> VAL)])
|
||||
|
||||
(: extend : (Listof Symbol) (Listof VAL) ENV -> ENV)
|
||||
;; extends an environment with a new frame.
|
||||
(define (extend names values env)
|
||||
(if (= (length names) (length values))
|
||||
(FrameEnv (map (lambda ([name : Symbol] [val : VAL])
|
||||
(list name val))
|
||||
names values)
|
||||
env)
|
||||
(error 'extend "arity mismatch for names: ~s" names)))
|
||||
|
||||
(: lookup : Symbol ENV -> VAL)
|
||||
;; lookup a symbol in an environment, frame by frame,
|
||||
;; 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)]
|
||||
[(FrameEnv frame rest)
|
||||
(let ([cell (assq name frame)])
|
||||
(if cell
|
||||
(second cell)
|
||||
(lookup name rest)))]))
|
||||
|
||||
(: unwrap-rktv : VAL -> Any)
|
||||
;; helper for `racket-func->prim-val': unwrap a RktV wrapper in
|
||||
;; preparation to be sent to the primitive function
|
||||
(define (unwrap-rktv x)
|
||||
(cases x
|
||||
[(RktV v) v]
|
||||
[else (error 'racket-func "bad input: ~s" x)]))
|
||||
|
||||
(: racket-func->prim-val : Function -> VAL)
|
||||
;; converts a racket function to a primitive evaluator function
|
||||
;; which is a PrimV holding a ((Listof VAL) -> VAL) function.
|
||||
;; (the resulting function will use the list function as is,
|
||||
;; and it is the list function's responsibility to throw an error
|
||||
;; if it's given a bad number of arguments or bad input types.)
|
||||
(define (racket-func->prim-val racket-func)
|
||||
(define list-func (make-untyped-list-function racket-func))
|
||||
(PrimV (lambda (args)
|
||||
(RktV (list-func (map unwrap-rktv args))))))
|
||||
|
||||
;; The global environment has a few primitives:
|
||||
(: global-environment : ENV)
|
||||
(define global-environment
|
||||
(FrameEnv (list (list '+ (racket-func->prim-val +))
|
||||
(list '- (racket-func->prim-val -))
|
||||
(list '* (racket-func->prim-val *))
|
||||
(list '/ (racket-func->prim-val /))
|
||||
(list '< (racket-func->prim-val <))
|
||||
(list '> (racket-func->prim-val >))
|
||||
(list '= (racket-func->prim-val =))
|
||||
;; values
|
||||
(list 'true (RktV #t))
|
||||
(list 'false (RktV #f)))
|
||||
(EmptyEnv)))
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Evaluation
|
||||
|
||||
(: eval : TOY ENV -> VAL)
|
||||
;; evaluates TOY expressions
|
||||
(define (eval expr env)
|
||||
;; convenient helper
|
||||
(: eval* : TOY -> VAL)
|
||||
(define (eval* expr) (eval expr env))
|
||||
(cases expr
|
||||
[(Num n) (RktV n)]
|
||||
[(Id name) (lookup name env)]
|
||||
[(Bind names exprs bound-body)
|
||||
(eval bound-body (extend names (map eval* exprs) env))]
|
||||
[(Fun names bound-body)
|
||||
(FunV names bound-body 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))]
|
||||
[else (error 'eval "function call with a non-function: ~s"
|
||||
fval)]))]
|
||||
[(If cond-expr then-expr else-expr)
|
||||
(eval* (if (cases (eval* cond-expr)
|
||||
[(RktV v) v] ; Racket value => use as boolean
|
||||
[else #t]) ; other values are always true
|
||||
then-expr
|
||||
else-expr))]))
|
||||
|
||||
(: run : String -> Any)
|
||||
;; evaluate a TOY program contained in a string
|
||||
(define (run str)
|
||||
(let ([result (eval (parse str) global-environment)])
|
||||
(cases result
|
||||
[(RktV v) v]
|
||||
[else (error 'run "evaluation returned a bad value: ~s"
|
||||
result)])))
|
||||
|
||||
;;; ----------------------------------------------------------------
|
||||
;;; Tests
|
||||
|
||||
(test (run "{{fun {x} {+ x 1}} 4}")
|
||||
=> 5)
|
||||
(test (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}")
|
||||
=> 4)
|
||||
(test (run "{bind {{add3 {fun {x} {+ x 3}}}
|
||||
{add1 {fun {x} {+ x 1}}}}
|
||||
{bind {{x 3}} {add1 {add3 x}}}}")
|
||||
=> 7)
|
||||
(test (run "{bind {{identity {fun {x} x}}
|
||||
{foo {fun {x} {+ x 1}}}}
|
||||
{{identity foo} 123}}")
|
||||
=> 124)
|
||||
(test (run "{bind {{x 3}}
|
||||
{bind {{f {fun {y} {+ x y}}}}
|
||||
{bind {{x 5}}
|
||||
{f 4}}}}")
|
||||
=> 7)
|
||||
(test (run "{{{fun {x} {x 1}}
|
||||
{fun {x} {fun {y} {+ x y}}}}
|
||||
123}")
|
||||
=> 124)
|
||||
|
||||
;; More tests for complete coverage
|
||||
(test (run "{bind x 5 x}") =error> "bad `bind' syntax")
|
||||
(test (run "{fun x x}") =error> "bad `fun' syntax")
|
||||
(test (run "{if x}") =error> "bad `if' syntax")
|
||||
(test (run "{}") =error> "bad syntax")
|
||||
(test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names")
|
||||
(test (run "{fun {x x} x}") =error> "duplicate*fun*names")
|
||||
(test (run "{+ x 1}") =error> "no binding for")
|
||||
(test (run "{+ 1 {fun {x} x}}") =error> "bad input")
|
||||
(test (run "{+ 1 {fun {x} x}}") =error> "bad input")
|
||||
(test (run "{1 2}") =error> "with a non-function")
|
||||
(test (run "{{fun {x} x}}") =error> "arity mismatch")
|
||||
(test (run "{if {< 4 5} 6 7}") => 6)
|
||||
(test (run "{if {< 5 4} 6 7}") => 7)
|
||||
(test (run "{if + 6 7}") => 6)
|
||||
(test (run "{fun {x} x}") =error> "returned a bad value")
|
||||
Reference in New Issue
Block a user