Last active
January 15, 2019 10:05
-
-
Save naxhh/ca88ae54afba45329a65 to your computer and use it in GitHub Desktop.
MUPL interpreter in racket
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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")))))))) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment