Skip to content

Instantly share code, notes, and snippets.

@mcclane

mcclane/gist:56da1c6998191732aac1f04922b9ad14

Created October 20, 2020 23:42
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mcclane/56da1c6998191732aac1f04922b9ad14 to your computer and use it in GitHub Desktop.
Save mcclane/56da1c6998191732aac1f04922b9ad14 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
gistfile1.txt
;; Test parse
(check-equal? (parse 10) (vc 10))
(check-equal? (parse -10) (vc -10))
(check-equal? (parse '{+ 10 5}) (appC (idC '+) (list (valueC (realV 10)) (valueC (realV 5)))))
(check-equal? (parse '{+ 10 {+ 2 3}}) (appC (idC '+) (list (valueC (realV 10)) (appC (idC '+)
(list (valueC (realV 2))
(valueC (realV 3)))))))
(check-equal? (parse '{* 10 5}) (appC (idC '*) (list (valueC (realV 10)) (valueC (realV 5)))))
(check-equal? (parse '{* 10 {+ 2 3}}) (appC (idC '*) (list (valueC (realV 10)) (appC (idC '+)
(list (valueC (realV 2))
(valueC (realV 3)))))))
(check-equal? (parse '{- 10 5}) (appC (idC '-) (list (valueC (realV 10)) (valueC (realV 5)))))
(check-equal? (parse '{/ 10 5}) (appC (idC '/) (list (valueC (realV 10)) (valueC (realV 5)))))
(check-equal? (parse '{if {<= {- 10 5} 0} {+ 10 5} {/ 10 5}})
(conditionalC
(appC (idC '<=) (list (appC (idC '-) (list (valueC (realV 10)) (valueC (realV 5)))) (valueC (realV 0))))
(appC (idC '+) (list (valueC (realV 10)) (valueC (realV 5))))
(appC (idC '/) (list (valueC (realV 10)) (valueC (realV 5))))))
(check-equal? (parse '{if {<= {- 10 15} 0} {+ 10 5} {/ 10 5}})
(conditionalC
(appC (idC '<=) (list (appC (idC '-) (list (valueC (realV 10)) (valueC (realV 15)))) (valueC (realV 0))))
(appC (idC '+) (list (valueC (realV 10)) (valueC (realV 5))))
(appC (idC '/) (list (valueC (realV 10)) (valueC (realV 5))))))
(check-equal? (parse '{if {<= {- 10 5} 0} 5 2})
(conditionalC
(appC (idC '<=) (list (appC (idC '-) (list (valueC (realV 10)) (valueC (realV 5)))) (valueC (realV 0))))
(valueC (realV 5))
(valueC (realV 2))))
(check-equal? (parse 'test) (idC 'test))
(check-equal? (parse '{addone x}) (appC (idC 'addone) (list (idC 'x))))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (interp (parse '{* 10 10 10}) root-env)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (interp (parse '{*}) root-env)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (interp (parse '{0}) root-env)))
(check-equal? (parse '{fn {x y z} {+ x {+ y z}}}) (lambdaC '(x y z)
(appC (idC '+)
(list (idC 'x)
(appC (idC '+)
(list (idC 'y)
(idC 'z)))))))
(check-equal? (parse '{fn {x} {+ x 1}}) (lambdaC '(x) (appC (idC '+) (list (idC 'x) (valueC (realV 1))))))
(check-equal? (parse '{fn {} {+ 2 1}}) (lambdaC '() (appC (idC '+) (list (valueC (realV 2)) (valueC (realV 1))))))
;; Defines the simple example from the specification. It's a good starting point to see if things
;; are basically working.
(define simpleProg1 '{let
{f = {fn {x} {+ x 14}}}
in
{f 2}})
(define simpleProg2 '{let
{f = {fn {x} {+ x 14}}}
{my-add = {fn {x y} {+ x y}}}
in
{f 2}})
(define simpleProg3 '{let
{f = {fn {x} {+ x 14}}}
{my-add = {fn {x y} {+ x y}}}
in
{my-add 2 3}})
;; TODO: Fix! It looks like the let rule doesn't recognize an unwrapped expression in the last position. This
;; Does work in the DXUQ simulator.
;; NOTE: Make sure to re-enable the unit test below.
(define simpleProg4 '{let
{f = {fn {x} {+ x 14}}}
{my-add = {fn {x y} {+ x y}}}
{my-const = -1}
in
my-const})
(define badSymbolProg '{let
{f = {fn {x} {+ x 14}}}
{my-add = {fn {x y} {+ x y}}}
{my-const = -1}
in
if})
;; NOTE: Program should fail, as it relies on dynamic scope.
(define midTermProg '{let
{f = {fn {x y} {+ {g x} y}}}
{g = {fn {n} {+ n 1}}}
in
{f 1 {g 2}}})
(define badProg1 '{let
{f = {fn {x x} {+ x x}}}
in
{f 2 3}})
(define badProg2 '{let
{in = {fn {x y} {- x y}}}
in
{+ 2 3}})
(check-equal? (top-interp simpleProg1) "16")
(check-equal? (top-interp simpleProg2) "16")
(check-equal? (top-interp simpleProg3) "5")
(check-equal? (top-interp simpleProg4) "-1")
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp midTermProg)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp badProg1)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp badProg2)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp badSymbolProg)))
;; Test interp
(check-equal? (interp (parse 10) root-env) (realV 10))
(check-equal? (interp (parse -10) root-env) (realV -10))
(check-equal? (interp (parse '{+ 10 5}) root-env) (realV 15))
(check-equal? (interp (parse '{+ 10 {+ 2 3}}) root-env) (realV 15))
(check-equal? (interp (parse '{* 10 5}) root-env) (realV 50))
(check-equal? (interp (parse '{* 10 {+ 2 3}}) root-env) (realV 50))
(check-equal? (interp (parse '{- 10 5}) root-env) (realV 5))
(check-equal? (interp (parse '{/ 10 5}) root-env) (realV 2))
(check-exn (regexp (regexp-quote "division by zero"))
(λ () (interp (parse '{/ 10 {- 3 3}}) root-env)))
(check-equal? (interp (parse '{if {<= {- 10 5} 0} {+ 10 5} {/ 10 5}}) root-env) (realV 2))
(check-equal? (interp (parse '{if {<= {- 10 15} 0} {+ 10 5} {/ 10 5}}) root-env) (realV 15))
(check-equal? (interp (parse '{if {<= {- 10 5} 0} 5 2}) root-env) (realV 2))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (interp (parse '{if "mom" {+ 10 5} {/ 10 5}}) root-env)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{if {<= {- 10 5} 0} {+ 10 5} {/ 10 5} 0})))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{if {<= {- 10 5} 0} {+ 10 5}})))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{if {<= {- 10 5} 0}})))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{if})))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{{fn {x} {+ x x}} 10 10})))
(define simpleEnv (append root-env (list (Binding 'x (realV 5.0)) (Binding 'y (realV 7.0)))))
(check-equal? (interp (appC (idC '+) (list (idC 'x) (idC 'y))) simpleEnv) (realV 12.0))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (interp (appC (idC '+) (list (valueC (realV 10)) (idC 'false))) root-env)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{{fn {x x} {+ x x}} 1 2})))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{+ if var})))
;; Test primitive-get
(check-true (procedure? (primitive-get '+)))
(check-true (procedure? (primitive-get '-)))
(check-true (procedure? (primitive-get '*)))
(check-true (procedure? (primitive-get '/)))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (primitive-get '✕)))
;; Test is-primitive?
(check-true (is-primitive? '+))
(check-true (is-primitive? '-))
(check-true (is-primitive? '*))
(check-true (is-primitive? '/))
(check-false (is-primitive? '✕))
;; Test top-interp
(check-equal? (top-interp '{{fn {x y} {+ x y}} 1 2}) "3")
(check-equal? (top-interp '{<= 1 0}) "false")
(check-equal? (top-interp '{<= 1 2}) "true")
(check-equal? (top-interp '{equal? "hi" "hi"}) "true")
(check-equal? (top-interp '{equal? "hi" "mom"}) "false")
;; Tests for serialize
(check-equal? (serialize (realV 1.0)) "1.0")
(check-equal? (serialize (boolV #t)) "true")
(check-equal? (serialize (boolV false)) "false")
(check-equal? (serialize (stringV "hi")) "\"hi\"")
(check-equal? (serialize (closureV (list 'x 'y 'z) (valueC (realV 10)) empty-env)) "#<procedure>")
(check-equal? (serialize (primitiveV '+)) "#<primop>")
;; Test for value-type
(check-equal? (value-type (valueC-value (vc 10))) "Real")
(check-equal? (value-type (valueC-value (vc #t))) "Bool")
(check-equal? (value-type (valueC-value (vc "hi"))) "String")
(check-equal? (value-type (closureV '(a b c) (valueC (realV 10)) empty-env)) "Closure")
(check-equal? (value-type (primitiveV 'a)) "Primitive")
;; Test some additional environment stuff
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (env-get root-env 'not-def)))
(check-equal? (env-get root-env 'true) (boolV #t))
;; About the only thing I could think of that'd still produce an error in parsing.
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{{}})))
;; Test internal-equal?
(let ([s1 (stringV "a")] [s2 (stringV "b")] [s3 (stringV "a")]
[b1 (boolV #t)] [b2 (boolV #f)]
[r1 (realV 1.0)] [r2 (realV 2.0)] [r3 (realV 1.0)]
[p1 (primitiveV '+)] [p2 (primitiveV '-)] [p3 (primitiveV '+)])
(check-false (internal-equal? (list s1 s2)))
(check-true (internal-equal? (list s1 s3)))
(check-false (internal-equal? (list r1 r2)))
(check-true (internal-equal? (list r1 r3)))
(check-false (internal-equal? (list b1 s2)))
(check-true (internal-equal? (list b1 b1)))
(check-false (internal-equal? (list s1 b1)))
(check-false (internal-equal? (list p1 p2)))
(check-false (internal-equal? (list p1 p3)))
)
;; Test let statements
(check-equal? (top-interp '{let {z = {+ 9 14}} {y = 98} in {+ z y}}) "121")
(check-equal? (top-interp '{let in {+ 2 1}}) "3")
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (top-interp '{let {= {+ 9 14}} {y = 98} in {+ z y}})))
(check-exn (regexp (regexp-quote "DXUQ"))
(λ () (let-get-arg-expr '{{z = } {y = 98}})))
;; Test symbol-is-protected?
(check-false (symbol-is-valid-name? '+))
(check-false (symbol-is-valid-name? 'if))
(check-true (symbol-is-valid-name? '%))
(check-false (symbol-is-protected? '+))
(check-true (symbol-is-protected? 'fn))
;; Test arg-names-are-valid?
(check-false (args-first-duplicate (list 'a 'b 'c)))
(check-equal? (args-first-duplicate (list 'a 'b 'b 'c)) 'b)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment