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.
645 lines
18 KiB
Racket
Executable File
645 lines
18 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 "check-modules.rkt") ; for type-of-program
|
|
(require "interp.rkt") ; for value-of-program
|
|
|
|
;; run : String -> ExpVal
|
|
(define run
|
|
(lambda (string)
|
|
(value-of-program (scan&parse string))))
|
|
|
|
(define tcheck
|
|
(lambda (string)
|
|
(type-to-external-form
|
|
(type-of-program (scan&parse string)))))
|
|
|
|
(define parse
|
|
(lambda (string)
|
|
(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 check-parse/type/run
|
|
(syntax-rules ()
|
|
[(check-parse/type/run (name str typ res) r ...)
|
|
(begin
|
|
(begin (check-not-exn (lambda () (parse str)))
|
|
(check equal-answer? (run str) 'res (symbol->string 'name))
|
|
(cond [(eqv? 'typ 'error)
|
|
(check-exn always? (lambda () (tcheck str)))]
|
|
[else
|
|
(check equal? (tcheck str) 'typ (symbol->string 'name))]))
|
|
(check-parse/type/run r ...))]
|
|
[(check-parse/type/run (name str typ) r ...)
|
|
(begin (check-not-exn (lambda () (parse str)))
|
|
(cond [(eqv? 'typ 'error)
|
|
(check-exn always? (lambda () (tcheck str)))]
|
|
[else
|
|
(check equal? (tcheck str) 'typ (symbol->string 'name))]))]))
|
|
|
|
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
|
|
|
|
(check-parse/type/run
|
|
(modules-dans-simplest "
|
|
module m1
|
|
interface
|
|
[a : int
|
|
b : int]
|
|
body
|
|
[a = 33
|
|
c = -(a,1)
|
|
b = -(c,a)]
|
|
|
|
let a = 10
|
|
in -(-(from m1 take a, from m1 take b),
|
|
a)"
|
|
int 24)
|
|
|
|
|
|
(example-8.2 "
|
|
module m1
|
|
interface
|
|
[u : bool]
|
|
body
|
|
[u = 33]
|
|
|
|
44"
|
|
error 44)
|
|
|
|
(example-8.3 "
|
|
module m1
|
|
interface
|
|
[u : int
|
|
v : int]
|
|
body
|
|
[u = 33]
|
|
|
|
44"
|
|
error)
|
|
|
|
(example-8.4 "
|
|
module m1
|
|
interface
|
|
[u : int
|
|
v : int]
|
|
body
|
|
[v = 33
|
|
u = 44]
|
|
|
|
from m1 take u"
|
|
error)
|
|
|
|
(example-8.5a "
|
|
module m1
|
|
interface
|
|
[u : int]
|
|
body
|
|
[u = 44]
|
|
|
|
module m2
|
|
interface
|
|
[v : int]
|
|
body
|
|
[v = -(from m1 take u,11)]
|
|
|
|
-(from m1 take u, from m2 take v)"
|
|
int)
|
|
|
|
(example-8.5b "
|
|
module m2
|
|
interface [v : int]
|
|
body
|
|
[v = -(from m1 take u,11)]
|
|
|
|
module m1
|
|
interface [u : int]
|
|
body [u = 44]
|
|
|
|
-(from m1 take u, from m2 take v)"
|
|
error)
|
|
|
|
(example-8.10"
|
|
module m1
|
|
interface
|
|
[transparent t = int
|
|
z : t
|
|
s : (t -> t)
|
|
is-z? : (t -> bool)]
|
|
body
|
|
[type t = int
|
|
z = 0
|
|
s = proc (x : t) -(x,-1)
|
|
is-z? = proc (x : t) zero?(x)]
|
|
|
|
let foo = proc (z : from m1 take t)
|
|
-(0, (from m1 take s
|
|
z))
|
|
in
|
|
(foo
|
|
from m1 take z)"
|
|
int -1)
|
|
|
|
(example-8.14 "
|
|
module m1
|
|
interface [transparent t = int
|
|
z : t]
|
|
body [type t = int
|
|
z = 0]
|
|
module m2
|
|
interface
|
|
[foo : (from m1 take t -> int)]
|
|
body
|
|
[foo = proc (x : from m1 take t) x]
|
|
|
|
from m2 take foo"
|
|
(int -> int))
|
|
|
|
(example-8.15 "
|
|
module m1
|
|
interface
|
|
[opaque t
|
|
z : t
|
|
s : (t -> t)
|
|
is-z? : (t -> bool)]
|
|
body
|
|
[type t = int
|
|
z = 0
|
|
s = proc (x : t) -(x,-1)
|
|
is-z? = proc (x : t) zero?(x)]
|
|
|
|
let foo = proc (z : from m1 take t)
|
|
(from m1 take s
|
|
(from m1 take s
|
|
z))
|
|
-(0, (foo
|
|
from m1 take z))"
|
|
error)
|
|
|
|
(example-8.15a "
|
|
module m1
|
|
interface
|
|
[opaque t
|
|
z : t
|
|
s : (t -> t)
|
|
is-z? : (t -> bool)]
|
|
body
|
|
[type t = int
|
|
z = 0
|
|
s = proc (x : t) -(x,-1)
|
|
is-z? = proc (x : t) zero?(x)]
|
|
|
|
let foo = proc (z : from m1 take t)
|
|
(from m1 take s
|
|
z)
|
|
in (foo
|
|
from m1 take z)"
|
|
(from m1 take t))
|
|
|
|
(example-8.8 "
|
|
module colors
|
|
interface
|
|
[opaque color
|
|
red : color
|
|
green : color
|
|
is-red? : (color -> bool)
|
|
switch-colors : (color -> color)]
|
|
body
|
|
[type color = int
|
|
red = 0
|
|
green = 1
|
|
is-red? = proc (c : color) zero?(c)
|
|
switch-colors = proc (c : color)
|
|
if (is-red? c) then green else red]
|
|
|
|
44"
|
|
int)
|
|
|
|
(example-8.9 "
|
|
module ints-1
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,-5)
|
|
pred = proc(x : t) -(x,5)
|
|
is-zero = proc (x : t) zero?(x)]
|
|
|
|
let zero = from ints-1 take zero
|
|
in let succ = from ints-1 take succ
|
|
in (succ (succ zero))"
|
|
(from ints-1 take t) 10)
|
|
|
|
(example-8.10 "
|
|
module ints-2
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,3)
|
|
pred = proc(x : t) -(x,-3)
|
|
is-zero = proc (x : t) zero?(x)]
|
|
|
|
let z = from ints-2 take zero
|
|
in let s = from ints-2 take succ
|
|
in (s (s z))"
|
|
(from ints-2 take t) -6)
|
|
|
|
(example-8.11 "
|
|
module ints-1
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,-5)
|
|
pred = proc(x : t) -(x,5)
|
|
is-zero = proc (x : t) zero?(x)]
|
|
let z = from ints-1 take zero
|
|
in let s = from ints-1 take succ
|
|
in let p = from ints-1 take pred
|
|
in let z? = from ints-1 take is-zero
|
|
in letrec int to-int (x : from ints-1 take t) =
|
|
if (z? x) then 0
|
|
else -((to-int (p x)), -1)
|
|
in (to-int (s (s z)))"
|
|
int 2)
|
|
|
|
(example-8.12 "
|
|
module ints-2
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,3)
|
|
pred = proc(x : t) -(x,-3)
|
|
is-zero = proc (x : t) zero?(x)
|
|
]
|
|
|
|
let z = from ints-2 take zero
|
|
in let s = from ints-2 take succ
|
|
in let p = from ints-2 take pred
|
|
in let z? = from ints-2 take is-zero
|
|
in letrec int to-int (x : from ints-2 take t) =
|
|
if (z? x) then 0
|
|
else -((to-int (p x)), -1)
|
|
in (to-int (s (s z)))"
|
|
int 2)
|
|
|
|
(example-8.13 "
|
|
module mybool
|
|
interface [opaque t
|
|
true : t
|
|
false : t
|
|
and : (t -> (t -> t))
|
|
not : (t -> t)
|
|
to-bool : (t -> bool)]
|
|
body [type t = int
|
|
true = 0
|
|
false = 13
|
|
and = proc (x : t)
|
|
proc (y : t)
|
|
if zero?(x)
|
|
then y
|
|
else false
|
|
not = proc (x : t)
|
|
if zero?(x)
|
|
then false
|
|
else true
|
|
to-bool = proc (x : t) zero?(x)]
|
|
|
|
let true = from mybool take true
|
|
in let false = from mybool take false
|
|
in let and = from mybool take and
|
|
in ((and true) false)"
|
|
(from mybool take t) 13)
|
|
|
|
;; (exercise-8.15 "
|
|
;; module tables
|
|
;; interface [opaque table
|
|
;; empty : table
|
|
;; add-to-table : (int -> (int -> (table -> table)))
|
|
;; lookup-in-table : (int -> (table -> int))]
|
|
;; body
|
|
;; [type table = (int -> int)
|
|
;; ... % to be filled in for exercise 8.15
|
|
;; ]
|
|
|
|
;; let empty = from tables take empty
|
|
;; in let add-binding = from tables take add-to-table
|
|
;; in let lookup = from tables take lookup-in-table
|
|
;; in let table1 = (((add-binding 3) 301)
|
|
;; (((add-binding 4) 400)
|
|
;; (((add-binding 3) 301)
|
|
;; empty)))
|
|
;; in -( ((lookup 4) table1),
|
|
;; ((lookup 3) table1))"
|
|
;; int 99)
|
|
|
|
(exercise-8.14 "
|
|
module mybool
|
|
interface [opaque t
|
|
true : t
|
|
false : t
|
|
and : (t -> (t -> t))
|
|
not : (t -> t)
|
|
to-bool : (t -> bool)]
|
|
body [type t = int
|
|
true = 1
|
|
false = 0
|
|
and = proc (x : t)
|
|
proc (y : t)
|
|
if zero?(x)
|
|
then false
|
|
else y
|
|
not = proc (x : t)
|
|
if zero?(x)
|
|
then true
|
|
else false
|
|
to-bool = proc (x : t)
|
|
if zero?(x)
|
|
then zero?(1)
|
|
else zero?(0)]
|
|
44"
|
|
int 44)
|
|
|
|
(alice-bob-and-charlie "
|
|
module Alices-point-builder
|
|
interface
|
|
((database : [opaque db-type
|
|
opaque node-type
|
|
insert-node : (node-type -> (db-type -> db-type))
|
|
])
|
|
=> [opaque point
|
|
initial-point : (int -> point)])
|
|
|
|
body
|
|
module-proc
|
|
(database : [opaque db-type
|
|
opaque node-type
|
|
insert-node : (node-type -> (db-type -> db-type))])
|
|
|
|
[type point = int
|
|
initial-point = proc (x : int) x]
|
|
|
|
module Bobs-db-module
|
|
interface
|
|
[opaque db-type
|
|
opaque node-type
|
|
insert-node : (node-type -> (db-type -> db-type))]
|
|
body
|
|
[type db-type = int
|
|
type node-type = bool
|
|
insert-node = proc (n : node-type) proc (d : db-type) d]
|
|
|
|
module Alices-points
|
|
interface
|
|
[opaque point
|
|
initial-point : (int -> point)]
|
|
body
|
|
(Alices-point-builder Bobs-db-module)
|
|
|
|
module Davids-db-module
|
|
interface
|
|
[opaque db-type
|
|
opaque node-type
|
|
insert-node : (node-type -> (db-type -> db-type))]
|
|
body
|
|
[type db-type = bool
|
|
type node-type = int
|
|
insert-node = proc (n : node-type) proc (d : db-type) d]
|
|
|
|
module Charlies-points
|
|
interface
|
|
[opaque point
|
|
initial-point : (int -> point)]
|
|
body
|
|
(Alices-point-builder Davids-db-module)
|
|
|
|
44"
|
|
int 44)
|
|
|
|
(example-8.15 "
|
|
module to-int-maker
|
|
interface
|
|
((m1 : [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)])
|
|
=> [to-int : (from m1 take t -> int)])
|
|
body
|
|
module-proc
|
|
(m1 : [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)])
|
|
[to-int
|
|
= let z? = from m1 take is-zero
|
|
in let p = from m1 take pred
|
|
in letrec int to-int (x : from m1 take t)
|
|
= if (z? x)
|
|
then 0
|
|
else -((to-int (p x)), -1)
|
|
in to-int]
|
|
|
|
module ints-1
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,-5)
|
|
pred = proc(x : t) -(x,5)
|
|
is-zero = proc (x : t) zero?(x)]
|
|
|
|
module ints-1-to-int
|
|
interface [to-int : (from ints-1 take t -> int)]
|
|
body
|
|
(to-int-maker ints-1)
|
|
|
|
let two1 = (from ints-1 take succ
|
|
(from ints-1 take succ
|
|
from ints-1 take zero))
|
|
in (from ints-1-to-int take to-int
|
|
two1)"
|
|
int 2)
|
|
|
|
|
|
(example-8.16 "
|
|
module to-int-maker
|
|
interface
|
|
((m1 : [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)])
|
|
=> [to-int : (from m1 take t -> int)])
|
|
body
|
|
module-proc
|
|
(m1 : [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)])
|
|
[to-int
|
|
= let z? = from m1 take is-zero
|
|
in let p = from m1 take pred
|
|
in letrec int to-int (x : from m1 take t)
|
|
= if (z? x)
|
|
then 0
|
|
else -((to-int (p x)), -1)
|
|
in to-int]
|
|
|
|
module ints-1
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,-5)
|
|
pred = proc(x : t) -(x,5)
|
|
is-zero = proc (x : t) zero?(x)]
|
|
|
|
|
|
module ints-2
|
|
interface [opaque t
|
|
zero : t
|
|
succ : (t -> t)
|
|
pred : (t -> t)
|
|
is-zero : (t -> bool)]
|
|
body [type t = int
|
|
zero = 0
|
|
succ = proc(x : t) -(x,3)
|
|
pred = proc(x : t) -(x,-3)
|
|
is-zero = proc (x : t) zero?(x)
|
|
]
|
|
|
|
module ints-1-to-int
|
|
interface [to-int : (from ints-1 take t -> int)]
|
|
body
|
|
(to-int-maker ints-1)
|
|
|
|
module ints-2-to-int
|
|
interface [to-int : (from ints-2 take t -> int)]
|
|
body
|
|
(to-int-maker ints-2)
|
|
|
|
|
|
let s1 = from ints-1 take succ
|
|
in let z1 = from ints-1 take zero
|
|
in let to-ints-1 = from ints-1-to-int take to-int
|
|
|
|
in let s2 = from ints-2 take succ
|
|
in let z2 = from ints-2 take zero
|
|
in let to-ints-2 = from ints-2-to-int take to-int
|
|
|
|
in let two1 = (s1 (s1 z1))
|
|
in let two2 = (s2 (s2 z2))
|
|
in -((to-ints-1 two1), (to-ints-2 two2))"
|
|
int 0)
|
|
|
|
;; (exercise-8.19 "
|
|
;; module sum-prod-maker
|
|
;; interface
|
|
;; ((m1 : [opaque t
|
|
;; zero : t
|
|
;; succ : (t -> t)
|
|
;; pred : (t -> t)
|
|
;; is-zero : (t -> bool)])
|
|
;; => [plus : (from m1 take t
|
|
;; -> (from m1 take t
|
|
;; -> from m1 take t))
|
|
;; times : (from m1 take t
|
|
;; -> (from m1 take t
|
|
;; -> from m1 take t))])
|
|
;; body
|
|
;; ... % to be filled in for exer. 8.19
|
|
|
|
;; 44"
|
|
;; int 44)
|
|
|
|
;; (exercise-8.22 "
|
|
;; module equality-maker
|
|
;; interface
|
|
;; ((m1 : [opaque t
|
|
;; zero : t
|
|
;; succ : (t -> t)
|
|
;; pred : (t -> t)
|
|
;; is-zero : (t -> bool)])
|
|
;; => [equal : (from m1 take t
|
|
;; -> (from m1 take t
|
|
;; -> bool))])
|
|
;; body
|
|
;; ...
|
|
;; 33"
|
|
;; int 33)
|
|
|
|
;; (exercise-8.19 "
|
|
;; module from-int-maker
|
|
;; interface
|
|
;; ((m1 : [opaque t
|
|
;; zero : t
|
|
;; succ : (t -> t)
|
|
;; pred : (t -> t)
|
|
;; is-zero : (t -> bool)])
|
|
;; => [from-int : (int -> from m1 take t)])
|
|
;; body
|
|
;; ...
|
|
;; 33"
|
|
;; int 33)
|
|
|
|
)
|
|
|
|
#;
|
|
(define tests-for-run
|
|
(let loop ((lst the-test-suite))
|
|
(cond
|
|
((null? lst) '())
|
|
((= (length (car lst)) 4)
|
|
;; (printf "creating item: ~s~%" (caar lst))
|
|
(cons
|
|
(list
|
|
(list-ref (car lst) 0)
|
|
(list-ref (car lst) 1)
|
|
(list-ref (car lst) 3))
|
|
(loop (cdr lst))))
|
|
(else (loop (cdr lst))))))
|
|
|
|
;; ok to have extra members in a test-item.
|
|
;;(define tests-for-check the-test-suite)
|
|
|
|
;;(define tests-for-parse the-test-suite)
|
|
|
|
|