10 Recursive Functions

#|
<expr> ::= <num>
         | {+ <expr> <expr>}
         | {- <expr> <expr>}
         | {if0 <expr> <expr> <expr>}
         | {with {<sym> <expr>} <expr>} --> syntactic sugar
         | <id>
         | {<expr> <expr>}
         | {fun {<sym>} <expr>}
         | {rec {<sym> <expr>} <expr>}
|#
(deftype Expr
  (num n)
  (add l r)
  (sub l r)
  (if0 c t f)
  (id s)
  (app fun-expr arg-expr)
  (fun id body)
  (rec id named-expr body))
 
;; parse :: s-expr -> Expr
#| where
   <s-expr> ::= <num>
              | <sym>
              | (list '+ <s-expr> <s-expr>)
              | (list '- <s-expr> <s-expr>)
              | (list 'if0 <s-expr> <s-expr> <s-expr>)
              | (list 'with (list <sym> <s-expr>) <s-expr>)
              | (list 'fun (list <sym>) <s-expr>)
              | (list 'rec (list <sym> <s-expr>) <s-expr>)
              | (list <s-expr> <s-expr>)
|#
(define (parse s-expr)
  (match s-expr
    [(? number?) (num s-expr)]
    [(? symbol?) (id s-expr)]
    [(list '+ l r) (add (parse l) (parse r))]
    [(list '- l r) (sub (parse l) (parse r))]
    [(list 'if0 c t f) (if0 (parse c)
                            (parse t)
                            (parse f))]
    [(list 'with (list x e) b)
     (app (fun x (parse b)) (parse e))]
    [(list 'rec (list x e) b)
     (rec x (parse e) (parse b))]
    [(list 'fun (list x) b) (fun x (parse b))]
    [(list f a) (app (parse f) (parse a))]))
 
;; values
(deftype Val
  (numV n)
  (closureV id body env))
 
 
#|-----------------------------
Environment abstract data type
(updated with recursive case)
 
empty-env  :: Env
env-lookup :: Sym Env -> Val
extend-env :: Sym Val Env -> Env
rec-extend-env :: Sym Box(Val) Env -> Env
 
|#
(deftype Env
  (mtEnv)
  (aEnv id val env)
  (aRecEnv id bval env))
 
(def empty-env  (mtEnv))
(def extend-env aEnv)
(def rec-extend-env aRecEnv)
 
(define (env-lookup x env)
  (match env
    [(mtEnv) (error 'env-lookup "free identifier: ~a" x)]
    [(aEnv id val rest)
     (if (symbol=? id x)
         val
         (env-lookup x rest))]
    [(aRecEnv id val rest)
     (if (symbol=? id x)
         (unbox val)
         (env-lookup x rest))]))
;;;;;;;
 
 
;; interp :: Expr Env -> Val
(define (interp expr env)
  (match expr
    [(num n) (numV n)]
    [(fun id body) (closureV id body env)]
    [(add l r) (num+ (interp l env) (interp r env))]
    [(sub l r) (num- (interp l env) (interp r env))]
    [(if0 c t f)
     (if (num-zero? (interp c env))
         (interp t env)
         (interp f env))]
    [(id x) (env-lookup x env)]
    [(app fun-expr arg-expr)
     (def (closureV id body fenv) (interp fun-expr env))
     (interp body
             (extend-env id
                         (interp arg-expr env)
                         fenv))]
    [(rec id named-expr body)
       (interp body
               (cyclic-env id named-expr env))]))
 
;; cyclic-env:: id expr env -> env (assumption: expr is a fun)
(define (cyclic-env id expr env)
  (def value-holder (box 'unspecified))
  (def new-env (rec-extend-env id value-holder env))
  (def fun-val (interp expr new-env))
  (set-box! value-holder fun-val)
  new-env)
 
(define (num+ n1 n2)
  (numV (+ (numV-n n1) (numV-n n2))))
 
(define (num- n1 n2)
  (numV (- (numV-n n1) (numV-n n2))))
 
(define (num-zero? n)
  (zero? (numV-n n)))
 
;; run :: s-expr -> number
(define (run prog)
  (match (interp (parse prog) empty-env)
    [(numV n) n]
    [(and f (closureV id body env)) f]))