这次回顾HW2，主要是实现一个简单的解释器。

课程主页：

https://www.coursera.org/learn/programming-languages-part-b/home

B站搬运：

https://www.bilibili.com/video/BV1tZ4y1D7

参考资料：

说明

假设定义了结构：

(struct apair (e1 e2)     #:transparent)

那么如下函数是自带的：

apair?
apair-e1
apair-e2

代码

;; Programming Languages, Homework 5

#lang racket
(provide (all-defined-out)) ;; so we can put tests in a second file

;; 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) 

;; Problem 1
(define (racketlist->mupllist racket-list)
  (if (null? racket-list)
    (aunit)
    (apair (car racket-list) (racketlist->mupllist (cdr racket-list)))))

;; Problem 2
(define (mupllist->racketlist mupl-list)
  (if (aunit? mupl-list)
    null
    (cons (apair-e1 mupl-list) (mupllist->racketlist (apair-e2 mupl-list)))))

;; lookup a variable in an environment
;; Do NOT change this function
(define (envlookup env str)
  (cond [(null? env) (error "unbound variable during evaluation" str)]
        [(equal? (car (car env)) str) (cdr (car env))]
        [#t (envlookup (cdr env) str)]))

;; Do NOT change the two cases given to you.  
;; DO add more cases for other kinds of MUPL expressions.
;; We will test eval-under-env by calling it directly even though
;; "in real life" it would be a helper function of eval-exp.
(define (eval-under-env e env)
  (cond [(var? e) 
         (envlookup env (var-string 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")))]
        ;; CHANGE add more cases here
        [(int? e) e]
        [(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")))]
        [(fun? e) (closure env e)]
        [(call? e)
         (let ([funexp (eval-under-env (call-funexp e) env)]
               [actual (eval-under-env (call-actual e) env)])
           (if (closure? funexp)
             (let ([funenv (closure-env funexp)]
                   [func (closure-fun funexp)]
                   ; 在当前env评估参数
                   [v (eval-under-env actual env)])
               (let* ([name (fun-nameopt func)]
                      [formal (fun-formal func)]
                      [body (fun-body func)]
                      [funenv (cons (cons formal v) funenv)])
                 (if name
                   (let ([funenv (cons (cons name funexp) funenv)])
                     (eval-under-env body funenv))
                   (eval-under-env body funenv))))
             (error "MUPL call? applied to non-closure")))]
        [(mlet? e)
         (let ([v (eval-under-env (mlet-e e) env)])
           (eval-under-env (mlet-body e) (cons (cons (mlet-var e) v) env)))]
        [(apair? e)
         (apair (eval-under-env (apair-e1 e) env) (eval-under-env (apair-e2 e) env))]
        [(fst? e)
         (let ([e (eval-under-env (fst-e e) env)])
            (if (apair? e)
              (apair-e1 e)
              (error "MUPL fst applied to non-apair")))]
        [(snd? e)
         (let ([e (eval-under-env (snd-e e) env)])
            (if (apair? e)
              (apair-e2 e)
              (error "MUPL snd applied to non-apair")))]
        [(isaunit? e)
         (let ([v (eval-under-env (isaunit-e e) env)])
           (if (aunit? v)
             (int 1)
             (int 0)))]
        [(closure? e) e]
        [(int? e) e]
        [(aunit? e) e]
        [#t (error (format "bad MUPL expression: ~v" e))]))

;; Do NOT change
(define (eval-exp e)
  (eval-under-env e null))
        
;; Problem 3
(define (ifaunit e1 e2 e3)
  (ifgreater (isaunit e1) (int 0) e2 e3))

(define (mlet* lstlst e2)
  (if (null? lstlst)
    e2
    (let* ([pair (car lstlst)])
      (mlet (car pair) (cdr pair) (mlet* (cdr lstlst) e2)))))

(define (ifeq e1 e2 e3 e4)
  (mlet* (list (cons "_x" e1) (cons "_y" e2))
    (ifgreater (var "_x") (var "_y")
      e4
      (ifgreater (var "_y") (var "_x") e4 e3))))

;; Problem 4
; https://github.com/houxianxu/programming-language-coursera/blob/master/hw5-section6/hw5-houxianxu.rkt
(define mupl-map
  (fun #f "fun"
    (fun "map" "lstlst"
      (ifaunit (var "lstlst")
        (aunit)
        (apair (call (var "fun") (fst (var "lstlst"))) 
               (call (var "map") (snd (var "lstlst"))))))))

(define mupl-mapAddN 
  (mlet "map" mupl-map
        (fun #f "n"
          (call (var "map") (fun #f "x" (add (var "x") (var "n")))))))

;; Challenge Problem

(struct fun-challenge (nameopt formal body freevars) #:transparent) ;; a recursive(?) 1-argument function

;; We will test this function directly, so it must do
;; as described in the assignment
(struct pair (expr fvar) #:transparent)

(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))))]
          ;; CHANGE add more cases here
          [(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))))]
          [(fun? e)
           (let* ([fun-pair (f (fun-body e))]
                  ; 总的free-vars减去参数
                  [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))
                  ; 删除let中变量
                  (set-union (pair-fvar e1) (set-remove (pair-fvar e2) (mlet-var e)))))]
          [(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)))]
          [(int? e) (pair e (set))]
          [(aunit? e) (pair e (set))]
          [(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)))

;; Do NOT share code with eval-under-env because that will make
;; auto-grading and peer assessment more difficult, so
;; copy most of your interpreter here and make minor changes
(define (eval-under-env-c e env)
  (cond [(var? e) 
         (envlookup env (var-string e))]
        [(add? e) 
         (let ([v1 (eval-under-env-c (add-e1 e) env)]
               [v2 (eval-under-env-c (add-e2 e) env)])
           (if (and (int? v1)
                    (int? v2))
               (int (+ (int-num v1) 
                       (int-num v2)))
               (error "MUPL addition applied to non-number")))]
        ;; CHANGE add more cases here
        [(int? e) e]
        [(ifgreater? e)
         (let ([v1 (eval-under-env-c (ifgreater-e1 e) env)]
               [v2 (eval-under-env-c (ifgreater-e2 e) env)])
           (if (and (int? v1)
                    (int? v2))
               (if (> (int-num v1) (int-num v2))
                 (eval-under-env-c (ifgreater-e3 e) env)
                 (eval-under-env-c (ifgreater-e4 e) env))
               (error "MUPL ifgreater applied to non-number")))]
        [(fun-challenge? e) 
          ; 添加到env中
          (closure (set-map (fun-challenge-freevars e) (lambda (s) (cons s (envlookup env s)))) e)]
        [(call? e)
         (let ([funexp (eval-under-env-c (call-funexp e) env)]
               [actual (eval-under-env-c (call-actual e) env)])
           (if (closure? funexp)
             (let ([funenv (closure-env funexp)]
                   [func (closure-fun funexp)]
                   ; 在当前env评估参数
                   [v (eval-under-env-c actual env)])
               (let* ([name (fun-challenge-nameopt func)]
                      [formal (fun-challenge-formal func)]
                      [body (fun-challenge-body func)]
                      [funenv (cons (cons formal v) funenv)])
                 (if name
                   (let ([funenv (cons (cons name funexp) funenv)])
                     (eval-under-env-c body funenv))
                   (eval-under-env-c body funenv))))
             (error "MUPL call? applied to non-closure")))]
        [(mlet? e)
         (let ([v (eval-under-env-c (mlet-e e) env)])
           (eval-under-env-c (mlet-body e) (cons (cons (mlet-var e) v) env)))]
        [(apair? e)
         (apair (eval-under-env-c (apair-e1 e) env) (eval-under-env-c (apair-e2 e) env))]
        [(fst? e)
         (let ([e (eval-under-env-c (fst-e e) env)])
            (if (apair? e)
              (apair-e1 e)
              (error "MUPL fst applied to non-apair")))]
        [(snd? e)
         (let ([e (eval-under-env-c (snd-e e) env)])
            (if (apair? e)
              (apair-e2 e)
              (error "MUPL snd applied to non-apair")))]
        [(isaunit? e)
         (let ([v (eval-under-env-c (isaunit-e e) env)])
           (if (aunit? v)
             (int 1)
             (int 0)))]
        [(closure? e) e]
        [(int? e) e]
        [(aunit? e) e]
        [#t (error (format "bad MUPL expression: ~v" e))]))

;; Do NOT change this
(define (eval-exp-c e)
  (eval-under-env-c (compute-free-vars e) null))

; (define eval-exp eval-exp-c)

要测试challenge部分，把第一个eval-exp部分注释掉，并且取消最后一行的注释。

测试

#lang racket
;; Programming Languages Homework 5 Simple Test
;; Save this file to the same directory as your homework file
;; These are basic tests. Passing these tests does not guarantee that your code will pass the actual homework grader

;; Be sure to put your homework file in the same folder as this test file.
;; Uncomment the line below and, if necessary, change the filename
;;(require "hw5")

(require rackunit)
(require "01_homework-5-auto-grader_hw5.rkt")

(define tests
  (test-suite
   "Sample tests for Assignment 5"
   
   ;; check racketlist to mupllist with normal list
   (check-equal? (racketlist->mupllist (list (int 3) (int 4))) (apair (int 3) (apair (int 4) (aunit))) "racketlist->mupllist test")
   (check-equal? (racketlist->mupllist null) (aunit) "racketlist->mupllist test")

   ;; check mupllist to racketlist with normal list
   (check-equal? (mupllist->racketlist (apair (int 3) (apair (int 4) (aunit)))) (list (int 3) (int 4)) "mupllist->racketlist test")

   ;; tests if ifgreater returexp (mlet "x" (int 1) (add (int 5) (var "x")))) (int 6) "mlet test")
   
   ;; callns (int 2)
   (check-equal? (eval-exp (ifgreater (int 3) (int 4) (int 3) (int 2))) (int 2) "ifgreater test")
   
   ;; mlet test
   (check-equal? (eval-exp (call (closure '() (fun #f "x" (add (var "x") (int 7)))) (int 1))) (int 8) "call test")

   ;;fst test
   (check-equal? (eval-exp (fst (apair (int 1) (int 2)))) (int 1) "fst test")

   ;;snd test
   (check-equal? (eval-exp (snd (apair (int 1) (int 2)))) (int 2) "snd test")
   
   ;; isaunit test
   (check-equal? (eval-exp (isaunit (closure '() (fun #f "x" (aunit))))) (int 0) "isaunit test")
   
   ;; ifaunit test
   (check-equal? (eval-exp (ifaunit (int 1) (int 2) (int 3))) (int 3) "ifaunit test")
   
   ;; mlet* test
   (check-equal? (eval-exp (mlet* (list (cons "x" (int 10))) (var "x"))) (int 10) "mlet* test")
   
   ;; ifeq test
   (check-equal? (eval-exp (ifeq (int 1) (int 2) (int 3) (int 4))) (int 4) "ifeq test")
   
   ;; mupl-map test
   (check-equal? (eval-exp (call (call mupl-map (fun #f "x" (add (var "x") (int 7)))) (apair (int 1) (aunit)))) 
                 (apair (int 8) (aunit)) "mupl-map test")
   
   ;; problems 1, 2, and 4 combined test
   (check-equal? (mupllist->racketlist
   (eval-exp (call (call mupl-mapAddN (int 7))
                   (racketlist->mupllist 
                    (list (int 3) (int 4) (int 9)))))) (list (int 10) (int 11) (int 16)) "combined test")
   
   ))

(require rackunit/text-ui)
;; runs the test
(run-tests tests)

测试结果：

13 success(es) 0 failure(s) 0 error(s) 13 test(s) run