Programming Language Part B HW5

分享一下HW5的思路

本次的eval-under-env，和lecture上的arithmetic language一樣，通過recursively evaluate 各種自訂義的expression，return 一個MUPL的value

MUPL的structure如下

;; definition of structures for MUPL programs - Do NOT change
(struct var  (string) #:transparent)  ;; a variable, e.g., (var "foo")
(struct int  (num)    #:transparent)  ;; a constant number, e.g., (int 17)
(struct add  (e1 e2)  #:transparent)  ;; add two expressions
(struct ifgreater (e1 e2 e3 e4)    #:transparent) ;; if e1 > e2 then e3 else e4
(struct fun  (nameopt formal body) #:transparent) ;; a recursive(?) 1-argument function
(struct call (funexp actual)       #:transparent) ;; function call
(struct mlet (var e body) #:transparent) ;; a local binding (let var = e in body) 
(struct apair (e1 e2)     #:transparent) ;; make a new pair
(struct fst  (e)    #:transparent) ;; get first part of a pair
(struct snd  (e)    #:transparent) ;; get second part of a pair
(struct aunit ()    #:transparent) ;; unit value -- good for ending a list
(struct isaunit (e) #:transparent) ;; evaluate to 1 if e is unit else 0

;; a closure is not in "source" programs but /is/ a MUPL value; it is what functions evaluate to
(struct closure (env fun) #:transparent) 

由此可知MUPL的value是var, int, apair, aunit, closure, 其中var和apair比較特別，var真正指向的值需要利用envlookup獲取，apair不能假設holding a value，有可能holding an expression，需要繼續evaluate。暫時eval-under-env如下，知道是最基本的value就不用處理，直接return

(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(int? e) e]
        [(closure? e) e]
        [(apair? e) (let ([v1 (eval-under-env (apair-e1 e) env)]
                          [v2 (eval-under-env (apair-e2 e) env)])
                      (apair v1 v2))]
        [(aunit? e) (aunit)]
        [#t (error (format "bad MUPL expression: ~v" e))]))

然後處理與apair有關連的fst和snd，這兩個就是racket的car和cdr，e最終獲取的value有可能是int, aunit….，所以要先計算出e的最終value，確定是apair，才用apair-e1/apair-e2取出value

(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(int? e) e]
        [(closure? e) e]
        [(apair? e) (let ([v1 (eval-under-env (apair-e1 e) env)]
                          [v2 (eval-under-env (apair-e2 e) env)])
                      (apair v1 v2))]
        [(aunit? e) (aunit)]
        [(fst? e) (let ([v (eval-under-env (fst-e e) env)])
                    (if (apair? v)
                      (apair-e1 v)
                      (error "MUPL fst applied to non-apair")))]
        [(snd? e) (let ([v (eval-under-env (snd-e e) env)])
                    (if (apair? v)
                      (apair-e2 v)
                      (error "MUPL snd applied to non-apair")))]
        [#t (error (format "bad MUPL expression: ~v" e))]))

然後到isaunit, ifgreater 和 add，三個都同樣，先計算出e的最終value，才進行後續的比較等等，原理就像(+ 3 (+ 4 5))，(+ 4 5)是一個subexpression，需要先算出9才可以算(+ 3 9)。

(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(int? e) e]
        [(closure? e) e]
        [(add? e) 
                 (let ([v1 (eval-under-env (add-e1 e) env)]
                       [v2 (eval-under-env (add-e2 e) env)])
                   (if (and (int? v1)
                            (int? v2))
                       (int (+ (int-num v1) 
                               (int-num v2)))
                       (error "MUPL addition applied to non-number")))]
        [(ifgreater? e) 
                        (let ([v1 (eval-under-env (ifgreater-e1 e) env)]
                              [v2 (eval-under-env (ifgreater-e2 e) env)])
                          (if (and (int? v1) (int? v2))
                              (if (> (int-num v1) (int-num v2))
                                  (eval-under-env (ifgreater-e3 e) env)
                                  (eval-under-env (ifgreater-e4 e) env))
                              (error "MUPL ifgreater applied to non-number"))
                         )]
        [(apair? e) (let ([v1 (eval-under-env (apair-e1 e) env)]
                          [v2 (eval-under-env (apair-e2 e) env)])
                      (apair v1 v2))]
        [(aunit? e) (aunit)]
        [(isaunit? e) ( let ( [v (eval-under-env (isaunit-e e) env)])
                         (if (aunit? v)
                          (int 1)
                          (int 0)))]
        [(fst? e) (let ([v (eval-under-env (fst-e e) env)])
                    (if (apair? v)
                      (apair-e1 v)
                      (error "MUPL fst applied to non-apair")))]
        [(snd? e) (let ([v (eval-under-env (snd-e e) env)])
                    (if (apair? v)
                      (apair-e2 v)
                      (error "MUPL snd applied to non-apair")))]
        [#t (error (format "bad MUPL expression: ~v" e))]))

然後是fun，A function evaluates to a closure holding the function and the current environment，所以return closure就好了

(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(int? e) e]
        [(closure? e) e]
        [(add? e) 
                 (let ([v1 (eval-under-env (add-e1 e) env)]
                       [v2 (eval-under-env (add-e2 e) env)])
                   (if (and (int? v1)
                            (int? v2))
                       (int (+ (int-num v1) 
                               (int-num v2)))
                       (error "MUPL addition applied to non-number")))]
        [(ifgreater? e) 
                        (let ([v1 (eval-under-env (ifgreater-e1 e) env)]
                              [v2 (eval-under-env (ifgreater-e2 e) env)])
                          (if (and (int? v1) (int? v2))
                              (if (> (int-num v1) (int-num v2))
                                  (eval-under-env (ifgreater-e3 e) env)
                                  (eval-under-env (ifgreater-e4 e) env))
                              (error "MUPL ifgreater applied to non-number"))
                         )]
        [(apair? e) (let ([v1 (eval-under-env (apair-e1 e) env)]
                          [v2 (eval-under-env (apair-e2 e) env)])
                      (apair v1 v2))]
        [(aunit? e) (aunit)]
        [(isaunit? e) ( let ( [v (eval-under-env (isaunit-e e) env)])
                         (if (aunit? v)
                          (int 1)
                          (int 0)))]
        [(fst? e) (let ([v (eval-under-env (fst-e e) env)])
                    (if (apair? v)
                      (apair-e1 v)
                      (error "MUPL fst applied to non-apair")))]
        [(snd? e) (let ([v (eval-under-env (snd-e e) env)])
                    (if (apair? v)
                      (apair-e2 v)
                      (error "MUPL snd applied to non-apair")))]
        [(fun? e) (closure env e)]
        [#t (error (format "bad MUPL expression: ~v" e))]))

然後是mlet，mlet就是define a variable, (let var = e in body),而所有的binding都是放在env，所以就是指把新的var加到env，再使用新的env evaluate mlet-body

(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(int? e) e]
        [(closure? e) e]
        [(add? e) 
                 (let ([v1 (eval-under-env (add-e1 e) env)]
                       [v2 (eval-under-env (add-e2 e) env)])
                   (if (and (int? v1)
                            (int? v2))
                       (int (+ (int-num v1) 
                               (int-num v2)))
                       (error "MUPL addition applied to non-number")))]
        [(ifgreater? e) 
                        (let ([v1 (eval-under-env (ifgreater-e1 e) env)]
                              [v2 (eval-under-env (ifgreater-e2 e) env)])
                          (if (and (int? v1) (int? v2))
                              (if (> (int-num v1) (int-num v2))
                                  (eval-under-env (ifgreater-e3 e) env)
                                  (eval-under-env (ifgreater-e4 e) env))
                              (error "MUPL ifgreater applied to non-number"))
                         )]
        [(apair? e) (let ([v1 (eval-under-env (apair-e1 e) env)]
                          [v2 (eval-under-env (apair-e2 e) env)])
                      (apair v1 v2))]
        [(aunit? e) (aunit)]
        [(isaunit? e) ( let ( [v (eval-under-env (isaunit-e e) env)])
                         (if (aunit? v)
                          (int 1)
                          (int 0)))]
        [(fst? e) (let ([v (eval-under-env (fst-e e) env)])
                    (if (apair? v)
                      (apair-e1 v)
                      (error "MUPL fst applied to non-apair")))]
        [(snd? e) (let ([v (eval-under-env (snd-e e) env)])
                    (if (apair? v)
                      (apair-e2 v)
                      (error "MUPL snd applied to non-apair")))]
        [(fun? e) (closure env e)]
        [(mlet? e) (let ([v (eval-under-env (mlet-e e) env)])
                     (eval-under-env (mlet-body e) 
                                      (cons (cons (mlet-var e) v) env)))]
        [#t (error (format "bad MUPL expression: ~v" e))]))

最後是call，call的funexp一定要是closure才可以進行後續evaluation，先evaluate funexp ([cl (eval-under-env (call-funexp e) env)])，不是closure就throw error，然後evaluate actual的value ([arg (eval-under-env (call-actual e) env)])。我們要弄清楚call和fun之間的關係：

(struct fun  (nameopt formal body) #:transparent) ;; a recursive(?) 1-argument function
(struct call (funexp actual)       #:transparent) ;; function call

fun有3個field，nameopt，formal，body，nameopt就是fun的名字，可以輸入為#f表示Anonymous，formal就是argument的名字（只是名字），body就是function的body。

call有兩個field，funexp，actual，funexp就是一個closure包括env和fun本體，actual是真正傳到fun的value，fun的formal是argument的名字，call的actual是argument的value。

所以當進行call時，除了funexp的env，還需要加上argument這個variable (i.e. [bodyenv (cons (cons (fun-formal fn) arg) (closure-env cl))])，另外如果fun有nameopt，也需要加 (nameopt closure)這個variable (i.e.[bodyenv (if (fun-nameopt fn) (cons (cons (fun-nameopt fn) cl) bodyenv) bodyenv)] )。加好後就可以evalutate了 (i.e. (eval-under-env (fun-body fn) bodyenv)))

(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(int? e) e]
        [(closure? e) e]
        [(add? e) 
                 (let ([v1 (eval-under-env (add-e1 e) env)]
                       [v2 (eval-under-env (add-e2 e) env)])
                   (if (and (int? v1)
                            (int? v2))
                       (int (+ (int-num v1) 
                               (int-num v2)))
                       (error "MUPL addition applied to non-number")))]
        [(ifgreater? e) 
                        (let ([v1 (eval-under-env (ifgreater-e1 e) env)]
                              [v2 (eval-under-env (ifgreater-e2 e) env)])
                          (if (and (int? v1) (int? v2))
                              (if (> (int-num v1) (int-num v2))
                                  (eval-under-env (ifgreater-e3 e) env)
                                  (eval-under-env (ifgreater-e4 e) env))
                              (error "MUPL ifgreater applied to non-number"))
                         )]
        [(apair? e) (let ([v1 (eval-under-env (apair-e1 e) env)]
                          [v2 (eval-under-env (apair-e2 e) env)])
                      (apair v1 v2))]
        [(aunit? e) (aunit)]
        [(isaunit? e) ( let ( [v (eval-under-env (isaunit-e e) env)])
                         (if (aunit? v)
                          (int 1)
                          (int 0)))]
        [(fst? e) (let ([v (eval-under-env (fst-e e) env)])
                    (if (apair? v)
                      (apair-e1 v)
                      (error "MUPL fst applied to non-apair")))]
        [(snd? e) (let ([v (eval-under-env (snd-e e) env)])
                    (if (apair? v)
                      (apair-e2 v)
                      (error "MUPL snd applied to non-apair")))]
        [(fun? e) (closure env e)]
        [(mlet? e) (let ([v (eval-under-env (mlet-e e) env)])
                     (eval-under-env (mlet-body e) 
                                      (cons (cons (mlet-var e) v) env)))]
        [(call? e) 
         (let ([cl  (eval-under-env (call-funexp e) env)]
               [arg (eval-under-env (call-actual e) env)])
           (if (closure? cl)
               (let* ([fn (closure-fun cl)]
                      [bodyenv (cons (cons (fun-formal fn) arg) (closure-env cl))]
                      [bodyenv (if (fun-nameopt fn) (cons (cons (fun-nameopt fn) cl) bodyenv) bodyenv)])
                 (eval-under-env (fun-body fn) bodyenv))
               (error "MUPL funciton call with nonfunction")))]
        [#t (error (format "bad MUPL expression: ~v" e))]))

— — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — —

Challenge Problem:

compute-free-vars 整個只是用來找出fun-challenge的free-vars。freevars是一個set，儲存current scopte用到可是不在scope的variables。當拿到set後，後續evaluate時就可以用set-map建立一個freevars的env，這樣就不用把所有env都傳去做evaluation。

大概的做法是用pair，pair用來儲存expression和free variables，expression方面，除了處理fun時需要換成fun-challenge，其他一樣。而free variables 則是先找出哪裡可以定義variables，MUPL可以用mlet，fun的nameopt，fun的formal，三個位置進行新binding。

只有var是真的return一個holding one string的set，其他都是recursively evaluate，拿到底層的set，如果return的set多於一個，就用set-union刪除重複的elements。

(define (compute-free-vars e)
  (define (f e)
    (cond [(var? e) (pair e (set (var-string e)))]
          [(add? e) 
           (let ([e1 (f (add-e1 e))]
                 [e2 (f (add-e2 e))])
            (pair (add (pair-expr e1) (pair-expr e2)) 
                  (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(int? e) (pair e (set))]
          [(ifgreater? e)
           (let ([e1 (f (ifgreater-e1 e))]
                 [e2 (f (ifgreater-e2 e))]
                 [e3 (f (ifgreater-e3 e))]
                 [e4 (f (ifgreater-e4 e))])
            (pair (ifgreater (pair-expr e1) (pair-expr e2) (pair-expr e3) (pair-expr e4)) 
                  (set-union (pair-fvar e1) (pair-fvar e2) (pair-fvar e3) (pair-fvar e4))))]
          [(apair? e)
           (let ([e1 (f (apair-e1 e))]
                 [e2 (f (apair-e2 e))])
            (pair (apair (pair-expr e1) (pair-expr e2))
                  (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(fst? e)
           (let ([e1 (f (fst-e e))])
            (pair (fst (pair-expr e1)) (pair-fvar e1)))]
          [(snd? e)
           (let ([e1 (f (snd-e e))])
            (pair (snd (pair-expr e1)) (pair-fvar e1)))]
          [(isaunit? e)
           (let ([e1 (f (isaunit-e e))])
            (pair (isaunit (pair-expr e1)) (pair-fvar e1)))]
          [(aunit? e) (pair e (set))]
          [(call? e) (let ([e1 (f (call-funexp e))]
                           [e2 (f (call-actual e))])
                      (pair (call (pair-expr e1) (pair-expr e2))
                            (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(closure? e)
           (let ([e1 (f (closure-env e))]
                 [e2 (f (closure-fun e))])
             (pair (closure e (pair-expr e2))
                   (pair-fvar e2)))]))
    (pair-expr (f e)))

mlet：需要從return回來的body set刪去自己(set-remove)，因為自己在後續的scope不是free variables

(define (compute-free-vars e)
  (define (f e)
    (cond [(var? e) (pair e (set (var-string e)))]
          [(add? e) 
           (let ([e1 (f (add-e1 e))]
                 [e2 (f (add-e2 e))])
            (pair (add (pair-expr e1) (pair-expr e2)) 
                  (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(int? e) (pair e (set))]
          [(ifgreater? e)
           (let ([e1 (f (ifgreater-e1 e))]
                 [e2 (f (ifgreater-e2 e))]
                 [e3 (f (ifgreater-e3 e))]
                 [e4 (f (ifgreater-e4 e))])
            (pair (ifgreater (pair-expr e1) (pair-expr e2) (pair-expr e3) (pair-expr e4)) 
                  (set-union (pair-fvar e1) (pair-fvar e2) (pair-fvar e3) (pair-fvar e4))))]
          [(apair? e)
           (let ([e1 (f (apair-e1 e))]
                 [e2 (f (apair-e2 e))])
            (pair (apair (pair-expr e1) (pair-expr e2))
                  (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(fst? e)
           (let ([e1 (f (fst-e e))])
            (pair (fst (pair-expr e1)) (pair-fvar e1)))]
          [(snd? e)
           (let ([e1 (f (snd-e e))])
            (pair (snd (pair-expr e1)) (pair-fvar e1)))]
          [(isaunit? e)
           (let ([e1 (f (isaunit-e e))])
            (pair (isaunit (pair-expr e1)) (pair-fvar e1)))]
          [(aunit? e) (pair e (set))]
          [(call? e) (let ([e1 (f (call-funexp e))]
                           [e2 (f (call-actual e))])
                      (pair (call (pair-expr e1) (pair-expr e2))
                            (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(mlet? e) (let ([e1 (f (mlet-e e))]
                           [e2 (f (mlet-body e))])
                          (pair (mlet (mlet-var e) (pair-expr e1) (pair-expr e2))
                                (set-union (pair-fvar e1) (set-remove (pair-fvar e2) (mlet-var e)))))]
          [(closure? e)
           (let ([e1 (f (closure-env e))]
                 [e2 (f (closure-fun e))])
             (pair (closure e (pair-expr e2))
                   (pair-fvar e2)))]))
    (pair-expr (f e)))

fun: 需要從return回來的fun body set刪去argument和自己function name，因為自己在後續的scope不是free variables

(define (compute-free-vars e)
  (define (f e)
    (cond [(var? e) (pair e (set (var-string e)))]
          [(add? e) 
           (let ([e1 (f (add-e1 e))]
                 [e2 (f (add-e2 e))])
            (pair (add (pair-expr e1) (pair-expr e2)) 
                  (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(int? e) (pair e (set))]
          [(ifgreater? e)
           (let ([e1 (f (ifgreater-e1 e))]
                 [e2 (f (ifgreater-e2 e))]
                 [e3 (f (ifgreater-e3 e))]
                 [e4 (f (ifgreater-e4 e))])
            (pair (ifgreater (pair-expr e1) (pair-expr e2) (pair-expr e3) (pair-expr e4)) 
                  (set-union (pair-fvar e1) (pair-fvar e2) (pair-fvar e3) (pair-fvar e4))))]
          [(apair? e)
           (let ([e1 (f (apair-e1 e))]
                 [e2 (f (apair-e2 e))])
            (pair (apair (pair-expr e1) (pair-expr e2))
                  (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(fst? e)
           (let ([e1 (f (fst-e e))])
            (pair (fst (pair-expr e1)) (pair-fvar e1)))]
          [(snd? e)
           (let ([e1 (f (snd-e e))])
            (pair (snd (pair-expr e1)) (pair-fvar e1)))]
          [(isaunit? e)
           (let ([e1 (f (isaunit-e e))])
            (pair (isaunit (pair-expr e1)) (pair-fvar e1)))]
          [(aunit? e) (pair e (set))]
          [(fun? e) (let* ([fun-pair (f (fun-body e))] 
                           [free-vars (set-remove (pair-fvar fun-pair) (fun-formal e))] 
                           [free-vars (if (fun-nameopt e) (set-remove free-vars (fun-nameopt e)) free-vars)]) 
                           (pair (fun-challenge (fun-nameopt e) (fun-formal e) (pair-expr fun-pair) free-vars)
                                 free-vars))]
          [(call? e) (let ([e1 (f (call-funexp e))]
                           [e2 (f (call-actual e))])
                      (pair (call (pair-expr e1) (pair-expr e2))
                            (set-union (pair-fvar e1) (pair-fvar e2))))]
          [(mlet? e) (let ([e1 (f (mlet-e e))]
                           [e2 (f (mlet-body e))])
                          (pair (mlet (mlet-var e) (pair-expr e1) (pair-expr e2))
                                (set-union (pair-fvar e1) (set-remove (pair-fvar e2) (mlet-var e)))))]
          [(closure? e)
           (let ([e1 (f (closure-env e))]
                 [e2 (f (closure-fun e))])
             (pair (closure e (pair-expr e2))
                   (pair-fvar e2)))]))
    (pair-expr (f e)))

compute-free-vars 做好後，就到eval-under-env-c，這個和原本的幾乎一樣，除了處理fun-challenge要用set-map建立一個freevars的env

(define (eval-under-env-c e env) 
  (cond 
        [(fun-challenge? e)
         (closure (set-map (fun-challenge-freevars e)
                           (lambda (s) (cons s (envlookup env s))))
                  e)]
         ; call case uses fun-challenge as appropriate
         ; all other cases the same
        ...)

這樣就完成囉～

ref：

[embed]Programming Languages Part B HW2 这次回顾HW2，主要是实现一个简单的解释器。 课程主页： https://www.coursera.org/learn/programming-languages-part-b/home B站搬运：…doraemonzzz.com

[embed]Coursera Programming Languages, Part B 华盛顿大学 Homework 5 这次 Week 2 的作业比较难，任务目标是使用 $racket$ 给一个虚拟语言 $MUPL$ (made-up programming language) 写一个解释器 所以单独开个贴来好好分析一下 首先是 MUPL 语言的几个…www.cnblogs.com