7491e172ea
The eopl language is now racket-based rather than mzscheme-based. This test-suite, which was originally distributed on the book's web-site has been re-written in the new language. Changes include dropping all drscheme-init.scm and top.scm files. Remaining files were renamed to use the .rkt extension and edited to use the #lang syntax (instead of modulue). Require and provide forms were changed to reflect racket's syntax instead of mzscheme's (eg, only-in vs. only). Several occurrences of one-armed ifs were changed to use when and unless. All tests have been run successfully.
305 lines
8.4 KiB
Racket
Executable File
305 lines
8.4 KiB
Racket
Executable File
#lang eopl
|
|
(require tests/eopl/private/utils)
|
|
|
|
(require "data-structures.rkt") ; for expval constructors
|
|
(require "lang.rkt") ; for scan&parse
|
|
(require "checker.rkt") ; for type-of-program
|
|
(require "interp.rkt") ; for value-of-program
|
|
|
|
(require (only-in racket pretty-print))
|
|
|
|
(define instrument-cps (make-parameter #f))
|
|
|
|
;; run : String -> ExpVal
|
|
(define run
|
|
(lambda (string)
|
|
(value-of-program (scan&parse string))))
|
|
|
|
;; tcheck : string -> external-type
|
|
(define tcheck
|
|
(lambda (string)
|
|
(type-to-external-form
|
|
(type-of-program (scan&parse string)))))
|
|
|
|
(define equal-answer?
|
|
(lambda (ans correct-ans)
|
|
(equal? ans (sloppy->expval correct-ans))))
|
|
|
|
(define sloppy->expval
|
|
(lambda (sloppy-val)
|
|
(cond
|
|
((number? sloppy-val) (num-val sloppy-val))
|
|
((boolean? sloppy-val) (bool-val sloppy-val))
|
|
(else
|
|
(eopl:error 'sloppy->expval
|
|
"Can't convert sloppy value to expval: ~s"
|
|
sloppy-val)))))
|
|
|
|
(define-syntax-rule (check-run (name str res) ...)
|
|
(begin
|
|
(cond [(eqv? 'res 'error)
|
|
(check-exn always? (lambda () (run str)))]
|
|
[else
|
|
(check equal-answer? (run str) 'res (symbol->string 'name))])
|
|
...))
|
|
|
|
(define-syntax-rule (check-type (name str res) ...)
|
|
(begin
|
|
(cond [(eqv? 'res 'error)
|
|
(check-exn always? (lambda () (tcheck str)))]
|
|
[else
|
|
(check equal? (tcheck str) 'res (symbol->string 'name))])
|
|
...))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
|
|
(check-run
|
|
;; simple arithmetic
|
|
(positive-const "11" 11)
|
|
(negative-const "-33" -33)
|
|
(simple-arith-1 "-(44,33)" 11)
|
|
|
|
;; nested arithmetic
|
|
(nested-arith-left "-(-(44,33),22)" -11)
|
|
(nested-arith-right "-(55, -(22,11))" 44)
|
|
|
|
;; simple variables
|
|
(test-var-1 "x" 10)
|
|
(test-var-2 "-(x,1)" 9)
|
|
(test-var-3 "-(1,x)" -9)
|
|
|
|
;; simple unbound variables
|
|
(test-unbound-var-1 "foo" error)
|
|
(test-unbound-var-2 "-(x,foo)" error)
|
|
|
|
;; simple conditionals
|
|
(if-true "if zero?(0) then 3 else 4" 3)
|
|
(if-false "if zero?(1) then 3 else 4" 4)
|
|
|
|
;; test dynamic typechecking
|
|
(no-bool-to-diff-1 "-(zero?(0),1)" error)
|
|
(no-bool-to-diff-2 "-(1,zero?(0))" error)
|
|
(no-int-to-if "if 1 then 2 else 3" error)
|
|
|
|
;; make sure that the test and both arms get evaluated
|
|
;; properly.
|
|
(if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3)
|
|
(if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4)
|
|
|
|
;; and make sure the other arm doesn't get evaluated.
|
|
(if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3)
|
|
(if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4)
|
|
|
|
;; simple let
|
|
(simple-let-1 "let x = 3 in x" 3)
|
|
|
|
;; make sure the body and rhs get evaluated
|
|
(eval-let-body "let x = 3 in -(x,1)" 2)
|
|
(eval-let-rhs "let x = -(4,1) in -(x,1)" 2)
|
|
|
|
;; check nested let and shadowing
|
|
(simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1)
|
|
(check-shadowing-in-body "let x = 3 in let x = 4 in x" 4)
|
|
(check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2)
|
|
|
|
;; simple applications
|
|
(apply-proc-in-rator-pos "(proc(x : int) -(x,1) 30)" 29)
|
|
(interp-ignores-type-info-in-proc "(proc(x : (int -> int)) -(x,1) 30)" 29)
|
|
(apply-simple-proc "let f = proc (x : int) -(x,1) in (f 30)" 29)
|
|
(let-to-proc-1 "(proc(f : (int -> int))(f 30) proc(x : int)-(x,1))" 29)
|
|
|
|
|
|
(nested-procs "((proc (x : int) proc (y : int) -(x,y) 5) 6)" -1)
|
|
(nested-procs2 "let f = proc(x : int) proc (y : int) -(x,y) in ((f -(10,5)) 6)"
|
|
-1)
|
|
|
|
(y-combinator-1 "
|
|
let fix = proc (f : bool)
|
|
let d = proc (x : bool) proc (z : bool) ((f (x x)) z)
|
|
in proc (n : bool) ((f (d d)) n)
|
|
in let
|
|
t4m = proc (f : bool) proc(x : bool) if zero?(x) then 0 else -((f -(x,1)),-4)
|
|
in let times4 = (fix t4m)
|
|
in (times4 3)" 12)
|
|
|
|
;; simple letrecs
|
|
(simple-letrec-1 "letrec int f(x : int) = -(x,1) in (f 33)" 32)
|
|
(simple-letrec-2
|
|
"letrec int f(x : int) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
|
|
8)
|
|
|
|
(simple-letrec-3
|
|
"let m = -5
|
|
in letrec int f(x : int) = if zero?(x) then 0 else -((f -(x,1)), m) in (f 4)"
|
|
20)
|
|
|
|
; (fact-of-6 "letrec
|
|
; fact(x) = if zero?(x) then 1 else *(x, (fact sub1(x)))
|
|
;in (fact 6)"
|
|
; 720)
|
|
|
|
(HO-nested-letrecs
|
|
"letrec int even(odd : (int -> int)) = proc(x : int) if zero?(x) then 1 else (odd -(x,1))
|
|
in letrec int odd(x : int) = if zero?(x) then 0 else ((even odd) -(x,1))
|
|
in (odd 13)" 1)
|
|
|
|
)
|
|
|
|
|
|
(check-type
|
|
;; tests from run-tests:
|
|
|
|
;; simple arithmetic
|
|
(positive-const "11" int)
|
|
(negative-const "-33" int)
|
|
(simple-arith-1 "-(44,33)" int)
|
|
|
|
;; nested arithmetic
|
|
(nested-arith-left "-(-(44,33),22)" int)
|
|
(nested-arith-right "-(55, -(22,11))" int)
|
|
|
|
;; simple variables
|
|
(test-var-1 "x" int)
|
|
(test-var-2 "-(x,1)" int)
|
|
(test-var-3 "-(1,x)" int)
|
|
|
|
(zero-test-1 "zero?(-(3,2))" bool)
|
|
(zero-test-2 "-(2,zero?(0))" error)
|
|
|
|
;; simple unbound variables
|
|
(test-unbound-var-1 "foo" error)
|
|
(test-unbound-var-2 "-(x,foo)" error)
|
|
|
|
;; simple conditionals
|
|
(if-true "if zero?(1) then 3 else 4" int)
|
|
(if-false "if zero?(0) then 3 else 4" int)
|
|
|
|
;; make sure that the test and both arms get evaluated
|
|
;; properly.
|
|
(if-eval-test-true "if zero?(-(11,12)) then 3 else 4" int)
|
|
(if-eval-test-false "if zero?(-(11, 11)) then 3 else 4" int)
|
|
(if-eval-then "if zero?(1) then -(22,1) else -(22,2)" int)
|
|
(if-eval-else "if zero?(0) then -(22,1) else -(22,2)" int)
|
|
|
|
;; make sure types of arms agree (new for lang5-1)
|
|
|
|
(if-compare-arms "if zero?(0) then 1 else zero?(1)" error)
|
|
(if-check-test-is-boolean "if 1 then 11 else 12" error)
|
|
|
|
;; simple let
|
|
(simple-let-1 "let x = 3 in x" int)
|
|
|
|
;; make sure the body and rhs get evaluated
|
|
(eval-let-body "let x = 3 in -(x,1)" int)
|
|
(eval-let-rhs "let x = -(4,1) in -(x,1)" int)
|
|
|
|
;; check nested let and shadowing
|
|
(simple-nested-let "let x = 3 in let y = 4 in -(x,y)" int)
|
|
(check-shadowing-in-body "let x = 3 in let x = 4 in x" int)
|
|
(check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" int)
|
|
|
|
;; simple applications
|
|
(apply-proc-in-rator-pos "(proc(x : int) -(x,1) 30)" int)
|
|
(checker-doesnt-ignore-type-info-in-proc
|
|
"(proc(x : (int -> int)) -(x,1) 30)"
|
|
error)
|
|
(apply-simple-proc "let f = proc (x : int) -(x,1) in (f 30)" int)
|
|
(let-to-proc-1 "(proc(f : (int -> int))(f 30) proc(x : int)-(x,1))" int)
|
|
|
|
|
|
(nested-procs "((proc (x : int) proc (y : int) -(x,y) 5) 6)" int)
|
|
(nested-procs2
|
|
"let f = proc (x : int) proc (y : int) -(x,y) in ((f -(10,5)) 3)"
|
|
int)
|
|
|
|
;; simple letrecs
|
|
(simple-letrec-1 "letrec int f(x : int) = -(x,1) in (f 33)" int)
|
|
(simple-letrec-2
|
|
"letrec int f(x : int) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
|
|
int)
|
|
|
|
(simple-letrec-3
|
|
"let m = -5
|
|
in letrec int f(x : int) = if zero?(x) then -((f -(x,1)), m) else 0 in (f 4)"
|
|
int)
|
|
|
|
(double-it "
|
|
letrec int double (n : int) = if zero?(n) then 0
|
|
else -( (double -(n,1)), -2)
|
|
in (double 3)"
|
|
int)
|
|
|
|
;; tests of expressions that produce procedures
|
|
|
|
(build-a-proc-typed "proc (x : int) -(x,1)" (int -> int))
|
|
|
|
(build-a-proc-typed-2 "proc (x : int) zero?(-(x,1))" (int -> bool))
|
|
|
|
(bind-a-proc-typed
|
|
"let f = proc (x : int) -(x,1) in (f 4)"
|
|
int)
|
|
|
|
(bind-a-proc-return-proc
|
|
"let f = proc (x : int) -(x,1) in f"
|
|
(int -> int))
|
|
|
|
(type-a-ho-proc-1
|
|
"proc(f : (int -> bool)) (f 3)"
|
|
((int -> bool) -> bool))
|
|
|
|
(type-a-ho-proc-2
|
|
"proc(f : (bool -> bool)) (f 3)"
|
|
error)
|
|
|
|
(apply-a-ho-proc
|
|
"proc (x : int) proc (f : (int -> bool)) (f x)"
|
|
(int -> ((int -> bool) -> bool)))
|
|
|
|
(apply-a-ho-proc-2
|
|
"proc (x : int) proc (f : (int -> (int -> bool))) (f x)"
|
|
(int -> ((int -> (int -> bool)) -> (int -> bool))) )
|
|
|
|
(apply-a-ho-proc-3
|
|
"proc (x : int) proc (f : (int -> (int -> bool))) (f zero?(x))"
|
|
error)
|
|
|
|
(apply-curried-proc
|
|
"((proc(x : int) proc (y : int)-(x,y) 4) 3)"
|
|
int)
|
|
|
|
(apply-a-proc-2-typed
|
|
"(proc (x : int) -(x,1) 4)"
|
|
int)
|
|
|
|
(apply-a-letrec "
|
|
letrec int f(x : int) = -(x,1)
|
|
in (f 40)"
|
|
int)
|
|
|
|
(letrec-non-shadowing
|
|
"(proc (x : int)
|
|
letrec bool loop(x : bool) =(loop x)
|
|
in x
|
|
1)"
|
|
int)
|
|
|
|
|
|
(letrec-return-fact "
|
|
let times = proc (x : int) proc (y : int) -(x,y) % not really times
|
|
in letrec
|
|
int fact(x : int) = if zero?(x) then 1 else ((times x) (fact -(x,1)))
|
|
in fact"
|
|
(int -> int))
|
|
|
|
(letrec-apply-fact "
|
|
let times = proc (x : int) proc (y : int) -(x,y) % not really times
|
|
in letrec
|
|
int fact(x : int) = if zero?(x) then 1 else ((times x) (fact -(x,1)))
|
|
in (fact 4)"
|
|
int)
|
|
|
|
|
|
|
|
)
|