#lang plai (print-only-errors) (define-type FWAE [num (n number?)] [add (lhs FWAE?) (rhs FWAE?)] [sub (lhs FWAE?) (rhs FWAE?)] [with (name symbol?) (named-expr FWAE?) (body FWAE?)] [id (name symbol?)] [fun (param-name symbol?) (body FWAE?)] [app (fun-expr FWAE?) (arg-expr FWAE?)]) (define-type FWAE-Value [numV (n number?)] [funV (param-name symbol?) (body FWAE?)]) ;; parse : s-expression -> FWAE? (define (parse s-exp) (cond [(number? s-exp) (num s-exp)] [(symbol? s-exp) (id s-exp)] [(list? s-exp) (when (empty? s-exp) (error 'parse "the empty list is not a valid F1WAE")) (case (first s-exp) [(+) (check-pieces s-exp "add" 3) (add (parse (second s-exp)) (parse (third s-exp)))] [(-) (check-pieces s-exp "sub" 3) (sub (parse (second s-exp)) (parse (third s-exp)))] [(with) (check-pieces s-exp "with" 3) (check-pieces (second s-exp) "with binding pair" 2) (unless (symbol? (first (second s-exp))) (error 'parse "binding occurrence is not an identifier")) (with (first (second s-exp)) (parse (second (second s-exp))) (parse (third s-exp)))] [(fun) (check-pieces s-exp "fun" 3) (check-pieces (second s-exp) "parameter list" 1) (fun (first (second s-exp)) (parse (third s-exp)))] [else (check-pieces s-exp "app" 2) (app (parse (first s-exp)) (parse (second s-exp)))])] [else (error 'parse "wat")])) (define (check-pieces s-exp expected n-pieces) (unless (and (list? s-exp) (= n-pieces (length s-exp))) (error 'parse "expected ~a got ~a" expected s-exp))) ;; ---------------------------------------------------------------------------- ;; interp : FWAE? -> FWAE-Value? (define (interp an-fwae) (type-case FWAE an-fwae [num (n) (numV n)] [add (l r) (numop l r +)] [sub (l r) (numop l r -)] [with (name named-expr body) (interp (subst body name (interp named-expr)))] [id (name) (error 'interp "free identifier")] [fun (param-name body) (funV param-name body)] [app (fun-expr arg-expr) (define fun-val (interp fun-expr)) (define arg-val (interp arg-expr)) (unless (funV? fun-val) (error 'interp "expected function")) (interp (subst (funV-body fun-val) (funV-param-name fun-val) arg-val))])) ;; numop : FWAE? FWAE? (number? number? -> number?) -> FWAE-Value? (define (numop l r op) (define l-val (interp l)) (define r-val (interp r)) (unless (numV? l-val) (error 'interp "expected number: ~a" l-val)) (unless (numV? r-val) (error 'interp "expected number: ~a" r-val)) (numV (op (numV-n l-val) (numV-n r-val)))) ;; subst : FWAE? symbol? FWAE-Value? -> FWAE? (define (subst an-fwae name value) (type-case FWAE an-fwae [num (val) an-fwae] [add (l r) (add (subst l name value) (subst r name value))] [sub (l r) (sub (subst l name value) (subst r name value))] [with (n named-expr body) (with n (subst named-expr name value) (if (equal? name n) body (subst body name value)))] [id (name2) ;; getting an FWAE-Value, need to produce an FWAE... (if (equal? name name2) (type-case FWAE-Value value [numV (n) (num n)] [funV (param-name body) (fun param-name body)]) an-fwae)] [app (fun-expr arg-expr) (app (subst fun-expr name value) (subst arg-expr name value))] [fun (param-name body) (fun param-name (if (equal? name param-name) body (subst body name value)))])) (test (interp (parse `{with {f {fun {x} {+ 1 x}}} {f 3}})) (numV 4)) (test (interp (parse `{{fun {x} {+ x 1}} 3})) (numV 4)) (test/exn (interp (parse `{1 2})) "expected function") (test/exn (interp (parse `{+ 1 {fun {x} 10}})) "expected number") (test/exn (interp (parse `{with {f {fun {x} {+ x y}}} {with {y 10} {f 3}}})) "free identifier") ;; ---------------------------------------------------------------------------- (test (subst (id 'x) 'x (numV 10)) (num 10)) (test (subst (id 'y) 'x (numV 10)) (id 'y)) (test (subst (add (id 'x) (id 'y)) 'x (numV 10)) (add (num 10) (id 'y))) (test (subst (add (id 'x) (id 'y)) 'y (numV 10)) (add (id 'x) (num 10))) (test (subst (with 'y (num 10) (id 'x)) 'x (numV 10)) (with 'y (num 10) (num 10))) (test (subst (with 'x (num 4) (id 'x)) 'x (numV 10)) (with 'x (num 4) (id 'x))) (test (subst (with 'x (id 'x) (num 5)) 'x (numV 10)) (with 'x (num 10) (num 5))) ;; 5 (test (parse `5) (num 5)) (test (interp (num 5)) (numV 5)) ;; {+ 5 2} (test (parse `{+ 5 2}) (add (num 5) (num 2))) (test (interp (add (num 5) (num 2))) (numV 7)) ;; {{+ 3 4} + {- 2 5}} ;; WRONG ;; {- 3 {+ 4 5}} (test (parse `{- 3 {+ 4 5}}) (sub (num 3) (add (num 4) (num 5)))) (test (interp (sub (num 3) (add (num 4) (num 5)))) (numV -6)) ;; x (test (parse `x) (id 'x)) (test/exn (interp (id 'x)) "free identifier") ;; {with {x 3} x} (test (parse `{with {x 3} x}) (with 'x (num 3) (id 'x))) (test (interp (with 'x (num 3) (id 'x))) (numV 3)) (test (parse `{with {x {+ 1 2}} x}) (with 'x (add (num 1) (num 2)) (id 'x))) (test (interp (with 'x (add (num 1) (num 2)) (id 'x))) (numV 3)) (test (parse `{with {x 3} {with {x 2} x}}) (with 'x (num 3) (with 'x (num 2) (id 'x)))) (test (interp (with 'x (num 3) (with 'x (num 2) (id 'x)))) (numV 2)) (test (parse `{with {y 3} {with {x 2} {+ x y}}}) (with 'y (num 3) (with 'x (num 2) (add (id 'x) (id 'y))))) (test (interp (with 'y (num 3) (with 'x (num 2) (add (id 'x) (id 'y))))) (numV 5)) ;; {with {x x} {+ x 1}} (test (parse `{with {x x} {+ x 1}}) (with 'x (id 'x) (add (id 'x) (num 1)))) (test/exn (interp (with 'x (id 'x) (add (id 'x) (num 1)))) "free identifier") (test (subst (num 5) 'x (numV 10)) (num 5)) (test (subst (sub (id 'x) (id 'y)) 'x (numV 10)) (sub (num 10) (id 'y))) (test (subst (sub (id 'x) (id 'y)) 'y (numV 10)) (sub (id 'x) (num 10))) (test (subst (with 'y (id 'x) (add (id 'y) (num 5))) 'x (numV 10)) (with 'y (num 10) (add (id 'y) (num 5)))) (test (parse `{with {x {with {y 3} y}} {+ x 4}}) (with 'x (with 'y (num 3) (id 'y)) (add (id 'x) (num 4)))) (test (interp (with 'x (with 'y (num 3) (id 'y)) (add (id 'x) (num 4)))) (numV 7)) (test (parse `{with {x {with {x 3} x}} {+ x 4}}) (with 'x (with 'x (num 3) (id 'x)) (add (id 'x) (num 4)))) (test (interp (with 'x (with 'x (num 3) (id 'x)) (add (id 'x) (num 4)))) (numV 7)) (test (interp (parse `{+ {with {x 2} x} {with {x 5} x}})) (numV 7))