UNB/ CS/ David Bremner/ teaching/ cs3613/ examples/ rflang.rkt
#lang plait
(define-type FLANG
  [Num  (val : Number)]
  [Add  (l : FLANG) (r : FLANG)]
  [Sub  (l : FLANG) (r : FLANG)]
  [Mul  (l : FLANG) (r : FLANG)]
  [Div  (l : FLANG) (r : FLANG)]
  [Id   (name : Symbol)]
  [If0 (test : FLANG) (then-part : FLANG) (else-part : FLANG)]
  [With (id : Symbol) (named-expr : FLANG) (bound-body : FLANG)]
  [Rec (id : Symbol) (named-expr : FLANG) (bound-body : FLANG)]
  [Fun  (param : Symbol) (body : FLANG)]
  [Call (fun : FLANG) (val : FLANG)])
(define-type VAL
  [NumV (n : Number)]
  [FunV (arg : Symbol) (body : FLANG) (env : ENV)])

(define (val->number v)
  (type-case VAL v
    [(NumV num) num]
    [else (error 'val-number "not a number")]))
(define-type ENV
  [EmptyEnv]
  [Extend (name : Symbol) (val : (Boxof VAL)) (end : ENV)])
(define (lookup name env)
  (type-case ENV env
    [(EmptyEnv) (error 'lookup (string-append "no binding for " (to-string name)))]
    [(Extend id boxed-val rest-env)
     (if (eq? id name) boxed-val (lookup name rest-env))]))
;; gets a Racket numeric binary operator, and uses it within a NumV
;; wrapper
(define (arith-op op val1 val2)
  (local
      [(define (NumV->number v)
         (type-case VAL v
           [(NumV n) n]
           [else (error 'arith-op (string-append "expects a number, got: " (to-string v)))]))]
    (NumV (op (NumV->number val1) (NumV->number val2)))))
;; evaluates FLANG expressions by reducing them to values
(define (eval expr env)
  (type-case FLANG expr
    [(Num n) (NumV n)]
    [(Add l r) (arith-op + (eval l env) (eval r env))]
    [(Sub l r) (arith-op - (eval l env) (eval r env))]
    [(Mul l r) (arith-op * (eval l env) (eval r env))]
    [(Div l r) (arith-op / (eval l env) (eval r env))]
    [(If0 test then-part else-part)
     (if (eq? 0 (val->number (eval test env)))
         (eval then-part env)
         (eval else-part env))]
    [(With bound-id named-expr bound-body)
     (eval bound-body
           (Extend bound-id (box (eval named-expr env)) env))]
    [(Rec bound-id named-expr bound-body)
     (eval bound-body
           (extend-rec bound-id named-expr env))]
    [(Id name) (unbox (lookup name env))]
    [(Fun bound-id bound-body)
     (FunV bound-id bound-body env)]
    [(Call fun-expr arg-expr)
     (let ([fval (eval fun-expr env)])
       (type-case VAL fval
         [(FunV bound-id bound-body f-env)
          (eval bound-body
                (Extend bound-id (box (eval arg-expr env)) f-env))]
         [else (error 'eval (string-append "`call' expects a function, got: "
                                           (to-string fval)))]))]))
(define (extend-rec id expr rest-env)
  (let ([new-cell (box (NumV 42))])
    (let ([new-env (Extend id new-cell rest-env)])
      (let ([value (eval expr new-env)])
        (begin
          (set-box! new-cell value)
          new-env)))))
(define (parse-error sx)
  (error 'parse-sx (string-append "parse error: " (to-string sx))))

(define (sx-ref sx n) (list-ref (s-exp->list sx) n))

(define (parse-sx sx)
  (local
      [(define (px i) (parse-sx (sx-ref sx i)))
       (define (with-rec-pieces sx)
         (let* ([def (sx-ref sx 1)]
                [id (s-exp->symbol (sx-ref def 0))]
                [val (parse-sx (sx-ref def 1))]
                [expr (parse-sx (sx-ref sx 2))])
           (values id val expr)))]
    (cond
      [(s-exp-number? sx) (Num (s-exp->number sx))]
      [(s-exp-symbol? sx) (Id (s-exp->symbol sx))]
      [(s-exp-match? `(with (SYMBOL ANY) ANY) sx)
       (local [(define-values (id val expr) (with-rec-pieces sx))]
         (With id val expr))]
      [(s-exp-match? `(rec (SYMBOL ANY) ANY) sx)
       (local [(define-values (id val expr) (with-rec-pieces sx))]
         (Rec id val expr))]
      [(s-exp-match? `(if0 ANY ANY ANY) sx)
       (If0 (px 1) (px 2) (px 3))]
      [(s-exp-match? `(fun (SYMBOL) ANY) sx)
       (let* ([args (sx-ref sx 1)]
              [id (s-exp->symbol (sx-ref args 0))]
              [body (parse-sx (sx-ref sx 2))])
         (Fun id body))]
      [(s-exp-list? sx)
       (let* ([l (λ () (parse-sx (sx-ref sx 1)))]
              [r (λ () (parse-sx (sx-ref sx 2)))])
         (case (s-exp->symbol (sx-ref sx 0))
           [(+) (Add (l) (r))]
           [(-) (Sub (l) (r))]
           [(*) (Mul (l) (r))]
           [(/) (Div (l) (r))]
           [(call) (Call (l) (r))]
           [else (parse-error sx)]))]
      [else (parse-error sx)])))


;; evaluate a FLANG program contained in a string
(define (run sx)
  (let ([result (eval (parse-sx sx) (EmptyEnv))])
    (type-case VAL result
      [(NumV n) n]
      [else (error 'run
                   (string-append
                    "evaluation returned a non-number " (to-string result)))])))