;; ** A call-by-need version of the SLOTH interpreter #lang pl ;;; ---------------------------------------------------------------- ;;; Syntax #| The BNF: ::= | | { bind {{ } ... } } | { fun { ... } } | { if } | { ... } |# ;; A matching abstract syntax tree datatype: (define-type SLOTH [Num Number] [Id Symbol] [Bind (Listof Symbol) (Listof SLOTH) SLOTH] [Fun (Listof Symbol) SLOTH] [Call SLOTH (Listof SLOTH)] [If SLOTH SLOTH SLOTH]) (: 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 -> SLOTH) ;; parses s-expressions into SLOTHs (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 -> SLOTH) ;; Parses a string containing an SLOTH expression to a SLOTH 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) SLOTH ENV] [ExprV SLOTH ENV (Boxof (U #f VAL))] [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': strict and unwrap a RktV ;; wrapper in preparation to be sent to the primitive function (define (unwrap-rktv x) (let ([s (strict x)]) (cases s [(RktV v) v] [else (error 'racket-func "bad input: ~s" s)]))) (: wrap-in-val : Any -> VAL) ;; helper that ensures a VAL output using RktV wrapper when needed, ;; but leaving as is otherwise (define (wrap-in-val x) (if (VAL? x) x (RktV x))) (: racket-func->prim-val : Function Boolean -> 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 strict?) (define list-func (make-untyped-list-function racket-func)) (PrimV (lambda (args) (let ([args (if strict? (map unwrap-rktv args) args)]) (wrap-in-val (list-func args)))))) ;; The global environment has a few primitives: (: global-environment : ENV) (define global-environment (FrameEnv (list (list '+ (racket-func->prim-val + #t)) (list '- (racket-func->prim-val - #t)) (list '* (racket-func->prim-val * #t)) (list '/ (racket-func->prim-val / #t)) (list '< (racket-func->prim-val < #t)) (list '> (racket-func->prim-val > #t)) (list '= (racket-func->prim-val = #t)) ;; note flags: (list 'cons (racket-func->prim-val cons #f)) (list 'list (racket-func->prim-val list #f)) (list 'first (racket-func->prim-val car #t)) (list 'rest (racket-func->prim-val cdr #t)) (list 'null? (racket-func->prim-val null? #t)) ;; values (list 'true (RktV #t)) (list 'false (RktV #f)) (list 'null (RktV null))) (EmptyEnv))) ;;; ---------------------------------------------------------------- ;;; Evaluation (: eval-promise : SLOTH ENV -> VAL) ;; used instead of `eval' to create an evaluation promise (define (eval-promise expr env) (ExprV expr env (box #f))) (: strict : VAL -> VAL) ;; forces a (possibly nested) ExprV promise, returns a VAL that is ;; not an ExprV (define (strict val) (cases val [(ExprV expr env cache) (or (unbox cache) (let ([val* (strict (eval expr env))]) (set-box! cache val*) val*))] [else val])) (: eval : SLOTH ENV -> VAL) ;; evaluates SLOTH expressions (define (eval expr env) ;; convenient helper (: eval* : SLOTH -> VAL) (define (eval* expr) (eval-promise 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) (define fval (strict (eval* fun-expr))) (define 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 (strict (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 SLOTH program contained in a string (define (run str) (let ([result (strict (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") ;; Test laziness (test (run "{{fun {x} 1} {/ 9 0}}") => 1) (test (run "{{fun {x} 1} {{fun {x} {x x}} {fun {x} {x x}}}}") => 1) (test (run "{bind {{x {{fun {x} {x x}} {fun {x} {x x}}}}} 1}") => 1) ;; Test lazy constructors (test (run "{bind {{l {list 1 {/ 9 0} 3}}} {+ {first l} {first {rest {rest l}}}}}") => 4) ;;; ----------------------------------------------------------------