#lang plai (print-only-errors #t) (define-type AE [num (n number?)] [binop (op procedure?) (lhs AE?) (rhs AE?)] [id (sym symbol?)] [app (fun AE?) (arg AE?)] [fun (param symbol?) (body AE?)]) (define (with name named-thing body) (app (fun name body) named-thing)) (define (add lhs rhs) (binop + lhs rhs)) (define (sub lhs rhs) (binop - lhs rhs)) ;; := ;; | (+ ) ;; | (- ) ;; | ;; | (with [ ] ) ;; | ( ) ;; | (fun () ) ;; where is any Racket symbol, except +, -, and with ;; parse :: s-expression -> AE (define (parse se) (cond [(and (list? se) (= 2 (length se))) (app (parse (first se)) (parse (second se)))] [(and (list? se) (= 3 (length se)) (equal? 'fun (first se)) (list? (second se)) (= 1 (length (second se))) (symbol? (first (second se)))) (fun (first (second se)) (parse (third se)))] [(and (list? se) (= 3 (length se)) (equal? 'with (first se)) (list? (second se)) (= 2 (length (second se))) (symbol? (first (second se)))) (with (first (second se)) (parse (second (second se))) (parse (third se)))] [(symbol? se) (id se)] [(number? se) (num se)] [(and (list? se) (= 3 (length se)) (equal? '+ (first se))) (add (parse (second se)) (parse (third se)))] [(and (list? se) (= 3 (length se)) (equal? '- (first se))) (sub (parse (second se)) (parse (third se)))] [else (error 'parse "Invalid syntax, dude: ~e" se)])) (test (parse '1) (num 1)) (test (parse '(+ 1 1)) (add (num 1) (num 1))) (test (parse '(- 1 1)) (sub (num 1) (num 1))) (test (parse 'x) (id 'x)) (test (parse '(with [x 27] x)) (with 'x (num 27) (id 'x))) (test (parse '(double 5)) (app (id 'double) (num 5))) (test (parse '(fun (x) (+ x x))) (fun 'x (add (id 'x) (id 'x)))) (test/exn (parse "1") "Invalid syntax") (define-type Env [mtEnv] [consEnv (name symbol?) (named-value AEV?) (rest Env?)]) (define-type AEV [numV (n number?)] [exprV (expr AE?) (env Env?) (ans (or/c false/c AEV?))] [closureV (param symbol?) (body AE?) (env Env?)]) (define (lookup-id $ sym) (type-case Env $ [mtEnv () (error 'calc "You has a bad identifier, bro: ~e" sym)] [consEnv (name named-value rest) (if (symbol=? name sym) named-value (lookup-id rest sym))])) ;; calc : AE? Env? -> AEV? ;; compute the meaning of the AE (define (calc ae $) (printf "calc ~v\n" ae) (type-case AE ae [fun (param body) (closureV param body $)] [app (fun arg) (type-case AEV (! (calc fun $)) [closureV (arg-name fun-body fun-$) (calc fun-body (consEnv arg-name ;; (calc arg $) (exprV arg $ #f) fun-$))] [else (error 'calc "Not a function, man")])] [id (sym) (lookup-id $ sym)] [num (n) (numV n)] [binop (op lhs rhs) (numV (lift-numV op ;; strictness points --- places where we need to force promises (! (calc lhs $)) (! (calc rhs $))))])) ;; ! : AEV -> AEV (except not exprV) (define (! v) (type-case AEV v [exprV (expr env maybe-ans) (cond [maybe-ans maybe-ans] [else (define ans (! (calc expr env))) ;; store the ans...? ;; (exprV expr env ans) (set-exprV-ans! v ans) ;; we don't need these anymore: ;; (set-exprV-env! v (mtEnv)) ;; (set-exprV-expr! v (num 0)) ans])] [else v])) (define (lift-numV f . args) (apply f (map numV-n* args))) (define (numV-n* a) (if (numV? a) (numV-n a) (error 'calc "Not a number: ~e" a))) ;; calc* : sexpr -> number? (define (calc* se) (printf "test case start\n") (define res (! (calc (parse se) (mtEnv)))) (type-case AEV res [numV (n) n] [else res])) (test (calc* '1) 1) (test (calc* '(+ 1 1)) 2) (test (calc* '(- 0 1)) -1) (test (calc* '(with [x (+ 5 5)] (+ x x))) 20) (test (calc* '(with [y 7] (with [x y] (+ x x)))) 14) (test (calc* '(with [x (+ 5 5)] (with [x 7] (+ x x)))) 14) (test (calc* '(with [x (+ 5 5)] (+ x (with [x 7] (+ x x))))) 24) (test (calc* '(with [x (+ 5 5)] (+ (with [x 7] (+ x x)) x))) 24) (test (calc* '(with [x (+ 5 5)] (+ (with [x 7] (+ x x)) (with [x 8] (+ x x))))) (+ 14 16)) (test (calc* '(with [x 7] (with [y (+ 2 x)] (+ y 3)))) 12) (test (calc* '(with [y 7] (with [y (+ y 2)] (+ y 3)))) 12) (test (calc* '(with [x (+ 5 5)] 7)) 7) (test (calc* '(with [x (+ 5 5)] (+ x x))) 20) (test (calc* '(with [x (+ 5 6)] (+ x x))) 22) (test (calc* '(with [x 5] (with [y 5] (+ (+ x x) y)))) 15) (test (calc* '(with [x 5] (with [x (+ 1 x)] (+ (+ x x) x)))) 18) (test/exn (calc* '(with [x 5] (with [x (+ 1 x)] (+ (+ x x) y)))) "bro") (test (calc* '(with [x x] 5)) 5) (test (calc* '(fun (x) (+ x x))) (closureV 'x (add (id 'x) (id 'x)) (mtEnv))) (test (calc* '(+ 1 (+ 2 3))) 6) (test/exn (calc* '(+ 1 (fun (x) x))) "Not a number") (test/exn (calc* '(5 1)) "Not a function") (test (calc* '(with [double (fun (x) (+ x x))] (double 5))) 10) (test (calc* '(with [double (fun (x) (+ x x))] (with [triple (fun (x) (+ x (double x)))] (triple 5)))) 15) (test (calc* '(with [double (fun (x) (+ x x))] (with [triple (fun (x) (+ x (double x)))] (with [double (fun (x) (- x 6))] (triple 5))))) 15) (test (calc* '(with [x (+ (fun (x) x) 7)] 8)) 8) (test (calc* '((fun (x) 8) (+ (fun (x) x) 7))) 8) (test (calc* '(with [x 8] x)) 8) (test (calc* '(with [x 8] (with [y x] y))) 8) (test (calc* '(with [x (+ 8 8)] (+ x x))) 32)