MUPL interpreter in racket

interpreter.rkt

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

;; definition of structures for MUPL programs
(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; it is what functions evaluate to
(struct closure (env fun) #:transparent)

(define (racketlist->mupllist rl)
  (cond [(null? rl) (aunit)]
        [(null? (cdr rl)) (apair (car rl) (aunit))]
        [#t (apair (car rl) (racketlist->mupllist (cdr rl)))]))

(define (mupllist->racketlist ml)
  (cond [(aunit? ml) '()]
        [(apair? ml) (cons (apair-e1 ml) (mupllist->racketlist (apair-e2 ml)))]
        [#t ml]))


;; lookup a variable in an environment
(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)]))

;; 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))]
        [(int? 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 given a non integer condition")))]
        [(fun? e) (closure env e)]
        [(call? e)
         (let ([cl (eval-under-env (call-funexp e) env)])
           (if (closure? cl)
               (let* ([fn (closure-fun cl)]
                      [v (eval-under-env (call-actual e) env)]
                      [env (cons (cons (fun-formal fn) v) (closure-env cl))])
                 (if (fun-nameopt fn)
                   (let ([env (cons (cons (fun-nameopt fn) cl) env)])
                     (eval-under-env (fun-body fn) env))
                   (eval-under-env (fun-body fn) env)))
               (error "First param for call is not a closure")))]
        [(closure? e) (eval-under-env (closure-fun e) (closure-env e))]
        [(mlet? e)
         (let* ([v (eval-under-env (mlet-e e) env)]
               [env (cons (cons (mlet-var e) v) env)])
         (eval-under-env (mlet-body e) env))]
        [(apair? e) (apair
                     (eval-under-env (apair-e1 e) env)
                     (eval-under-env (apair-e2 e) env))]
        [(fst? e)
         (let ([p (eval-under-env (fst-e e) env)])
           (if (apair? p)
               (apair-e1 p)
               (error "fst expects to get a pair")))]
        [(snd? e)
         (let ([p (eval-under-env (snd-e e) env)])
           (if (apair? p)
               (apair-e2 p)
               (error "snd expects to get a pair")))]
        [(aunit? e) e]
        [(isaunit? e)
         (let ([ex (eval-under-env (isaunit-e e) env)])
           (if (aunit? ex)
               (int 1)
               (int 0)))]
        
        [#t (error (format "bad MUPL expression: ~v" e))]))

(define (eval-exp e)
  (eval-under-env e null))
        
(define (ifaunit e1 e2 e3) (ifgreater (isaunit e1) (int 0) e2 e3))

(define (mlet* lstlst e2)
  (if (null? lstlst)
      e2
      (let ([d (car lstlst)])
        (mlet (car d) (cdr d) (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 (add (var "_x") (int 1)) (var "_y")
             e3
             e4))))

(define mupl-map
  (fun #f "fn"
       (fun "map" "xs"
            (ifaunit (var "xs")
                     (aunit)
                     (apair (call (var "fn") (fst (var "xs"))) (call (var "map") (snd (var "xs"))))))))

interpreter_test.rkt

#lang racket
(require "interpreter.rkt")

(require rackunit)

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

   ;; test int
   (check-equal? (eval-exp (int 5)) (int 5) "should return int 5")
   
   ;; test add
   (check-equal? (eval-exp (add (int 5) (int 10))) (int 15) "should return int 15 when adding 5 and 10")
   
   ;; tests if ifgreater returns (int 2)
   (check-equal? (eval-exp (ifgreater (int 3) (int 4) (int 3) (int 2))) (int 2) "ifgreater test")
   (check-equal? (eval-exp (ifgreater (add (int 1) (int 2)) (int 3) (int 1) (int 5))) (int 5) "Should return 5 because is not strictly greater")
   
   ;; mlet test
   (check-equal? (eval-exp (mlet "x" (int 1) (add (int 5) (var "x")))) (int 6) "mlet test")
   (check-equal? (eval-exp (mlet "x" (int 1) (add (var "x") (var "x")))) (int 2) "mlet test")
   
   ;; call test
   (check-equal? (eval-exp (call (fun #f "x" (int 7)) (int 1))) (int 7) "Should return 7")
   (check-equal? (eval-exp (call (fun #f "x" (add (var "x") (int 7))) (int 1))) (int 8) "Should return 8")
   (check-equal? (eval-exp (call (closure '() (fun #f "x" (add (var "x") (int 7)))) (int 1))) (int 8) "call test")
   
   ;; Recursive call not supported yet because a problem in the env :)
   (check-equal? (eval-exp (call (fun "count" "x"
                                      (ifgreater (var "x") (int 5)
                                                 (int 2)
                                                 (call (var "count") (add (var "x") (int 1)))))
                                      (int 1))) (int 2) "Recursive call")
   
   ;; pair test
   (check-equal? (eval-exp (apair (add (int 1) (int 2)) (int 3))) (apair (int 3) (int 3)) "Should return a new pair")
   
   ;; 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")
   (check-equal? (eval-exp (isaunit (aunit))) (int 1) "isaunit test")
   
   ;; ifaunit test
   (check-equal? (eval-exp (ifaunit (int 1) (int 2) (int 3))) (int 3) "ifaunit test")
   (check-equal? (eval-exp (ifaunit (aunit) (add (int 2) (int 3)) (int 3))) (int 5) "ifaunit test")
   
   ;; mlet* test
   (check-equal? (eval-exp (mlet* (list (cons "x" (int 10))) (var "x"))) (int 10) "mlet* test")
   (check-equal? (eval-exp (mlet* (list (cons "x" (int 10)) (cons "y" (int 1))) (add (var "x") (var "y")))) (int 11) "testing with two vars")
   
   ;; ifeq test
   (check-equal? (eval-exp (ifeq (int 1) (int 2) (int 3) (int 4))) (int 4) "ifeq test")
   (check-equal? (eval-exp (ifeq (int 2) (int 2) (int 3) (int 4))) (int 3) "ifeq test")
   (check-equal? (eval-exp (ifeq (int 3) (int 2) (int 3) (int 4))) (int 4) "ifeq test")
   (check-equal? (eval-exp (ifeq (int 2) (int 3) (int 3) (int 4))) (int 4) "ifeq test")
   (check-equal? (eval-exp (ifeq (add (int 3) (int 1)) (add (int 2) (int 2)) (add (int 3) (int 2)) (int 4))) (int 5) "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)