suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import allcode.zip into test suite.

Browse Source
This commit is contained in:
David Van Horn 2012-02-21 16:23:17 -05:00 committed by Eli Barzilay
parent 0de95a0a79
commit b5a4ffcd55
225 changed files with 39557 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

191
collects/tests/eopl/chapter1/test-chap1.scm Executable file
View File

@ -0,0 +1,191 @@
(module test-chap1 mzscheme
;; This collects the code in chapter 1. It uses a very primitive
;; testing macro, equal??. This needs to be a macro because we print
;; the test as well as evaluate it.
;; We use a more sophisticated testing setup for the interpreters
;; later on.
(define-syntax equal??
(syntax-rules ()
((_ test-exp correct-ans)
(let ((observed-ans test-exp))
(if (not (equal? observed-ans correct-ans))
(printf "~s returned ~s, should have returned ~s~%"
'test-exp
observed-ans
correct-ans))))))
;; in-S? : N -> Bool
;; usage: (in-S? n) = #t if n is in S, #f otherwise
;; The set S is defined in Definition 1.1.1 on page 2.
(define in-S?
(lambda (n)
(if (zero? n) #t
(if (>= (- n 3) 0) (in-S? (- n 3))
#f))))
(equal?? (in-S? 4) #f)
(equal?? (in-S? 9) #t)
;; list-length : List -> Int
;; usage: (list-length l) = the length of l
;; Page: 14
(define list-length
(lambda (lst)
(if (null? lst)
0
(+ 1 (list-length (cdr lst))))))
(equal?? (list-length '(a (b c) d)) 3)
;; nth-element : List * Int -> SchemeVal
;; usage: (nth-element lst n) = the nth element of lst
;; Page: 15
(define nth-element
(lambda (lst n)
(if (null? lst)
(report-list-too-short n)
(if (zero? n)
(car lst)
(nth-element (cdr lst) (- n 1))))))
(define report-list-too-short
(lambda (n)
(error 'nth-element
"List too short by ~s elements.~%" (+ n 1))))
;; uncomment these to test equal??
;; (equal?? (nth-element '(a b c d) 2) 'foo)
;; (equal?? (nth-element '(a b c d) 3) 'bar)
(equal?? (nth-element '(a b c d) 2) 'c)
;; remove-first : Sym * Listof(Sym) -> Listof(Sym)
;; Page: 18
(define remove-first
(lambda (s los)
(if (null? los)
'()
(if (eqv? (car los) s)
(cdr los)
(cons (car los) (remove-first s (cdr los)))))))
(equal?? (remove-first 'a '(a b c)) '(b c))
(equal?? (remove-first 'b '(e f g)) '(e f g))
(equal?? (remove-first 'a4 '(c1 a4 c1 a4)) '(c1 c1 a4))
(equal?? (remove-first 'x '()) '())
;; occurs-free? : Sym * Lcexp -> Bool
;; usage:
;; returns #t if the symbol var occurs free in exp,
;; otherwise returns #f.
;; Page: 19
(define occurs-free?
(lambda (var exp)
(cond
((symbol? exp) (eqv? var exp))
((eqv? (car exp) 'lambda)
(and
(not (eqv? var (car (cadr exp))))
(occurs-free? var (caddr exp))))
(else
(or
(occurs-free? var (car exp))
(occurs-free? var (cadr exp)))))))
(equal?? (occurs-free? 'x 'x) #t)
(equal?? (occurs-free? 'x 'y) #f)
(equal?? (occurs-free? 'x '(lambda (x) (x y))) #f)
(equal?? (occurs-free? 'x '(lambda (y) (x y))) #t)
(equal?? (occurs-free? 'x '((lambda (x) x) (x y))) #t)
(equal?? (occurs-free? 'x '(lambda (y) (lambda (z) (x (y z))))) #t)
;; subst : Sym * Sym * S-list -> S-list
;; Page: 21
(define subst
(lambda (new old slist)
(if (null? slist)
'()
(cons
(subst-in-s-exp new old (car slist))
(subst new old (cdr slist))))))
;; subst-in-s-exp : Sym * Sym * S-exp -> S-exp
;; Page: 21
(define subst-in-s-exp
(lambda (new old sexp)
(if (symbol? sexp)
(if (eqv? sexp old) new sexp)
(subst new old sexp))))
(equal?? (subst 'a 'b '((b c) (b () d))) '((a c) (a () d)))
;; number-elements-from : Listof(SchemeVal) * Int ->
;; Listof(List(Int,SchemeVal))
;; usage: (number-elements-from '(v0 v1 v2 ...) n)
;; = ((n v0 ) (n+1 v1) (n+2 v2) ...)
;; Page: 23
(define number-elements-from
(lambda (lst n)
(if (null? lst) '()
(cons
(list n (car lst))
(number-elements-from (cdr lst) (+ n 1))))))
;; number-elements : List -> Listof(List(Int,SchemeVal))
;; Page: 23.
(define number-elements
(lambda (lst)
(number-elements-from lst 0)))
(equal?? (number-elements '(a b c d e)) '((0 a) (1 b) (2 c) (3 d) (4 e)))
;; list-sum : Listof(Int) -> Int
;; Page: 24
(define list-sum
(lambda (loi)
(if (null? loi)
0
(+ (car loi)
(list-sum (cdr loi))))))
(equal?? (list-sum (list 1 2 3 4 5)) 15)
;; partial-vector-sum : Vectorof(Int) * Int -> Int
;; usage if 0 <= n < length(v), then
;; (partial-vector-sum v n) = SUM(v_i from 0 <= i <= n)
;; Page: 25
(define partial-vector-sum
(lambda (v n)
(if (zero? n)
(vector-ref v 0)
(+ (vector-ref v n)
(partial-vector-sum v (- n 1))))))
;; vector-sum : Vectorof(Int) -> Int
;; usage (vector-sum v) = SUM(v_i from 0 <= i <= length(v)-1)
;; Page: 25
(define vector-sum
(lambda (v)
(let ((n (vector-length v)))
(if (zero? n)
0
(partial-vector-sum v (- n 1))))))
(equal?? (vector-sum (vector 1 2 3 4 5)) 15)
)

3
collects/tests/eopl/chapter2/README.txt Executable file
View File

@ -0,0 +1,3 @@
(* This directory intentionally left blank *)
The code snippets in this chapter will be posted at a later time.

92
collects/tests/eopl/chapter2/sec2.1.scm Executable file
View File

@ -0,0 +1,92 @@
(module sec2.1 (lib "eopl.ss" "eopl")
(require "utils.scm")
(let ()
;; Unary Representation
;; page 33
(define zero (lambda () '()))
(define is-zero? (lambda (n) (null? n)))
(define successor (lambda (n) (cons #t n)))
(define predecessor (lambda (n) (cdr n)))
;; Need this style of definition to define a recursive function
;; inside a let, sorry.
(define (plus x y)
(if (is-zero? x)
y
(successor (plus (predecessor x) y))))
(define (scheme-int->my-int n)
(if (zero? n) (zero)
(successor (scheme-int->my-int (- n 1)))))
(define (my-int->scheme-int x)
(if (is-zero? x) 0
(+ 1 (my-int->scheme-int (predecessor x)))))
(equal??
(my-int->scheme-int
(plus
(scheme-int->my-int 3)
(scheme-int->my-int 7)))
10)
(report-unit-tests-completed 'unary-representation)
)
(let ()
;; Scheme number representation
;; page 33
(define zero (lambda () 0))
(define is-zero? (lambda (n) (zero? n)))
(define successor (lambda (n) (+ n 1)))
(define predecessor (lambda (n) (- n 1)))
(define (plus x y)
(if (is-zero? x)
y
(successor (plus (predecessor x) y))))
(equal?? (plus 3 7) 10)
(report-unit-tests-completed 'scheme-number-representation)
)
(let ()
;; Reverse-number representation
;; Represent n by the Scheme number 5-n
(define zero (lambda () 5))
(define is-zero? (lambda (n) (= n 5)))
(define successor (lambda (n) (- n 5)))
(define predecessor (lambda (n) (+ n 5)))
;; unchanged below here!
(define plus
(lambda (x y)
(if (is-zero? x)
y
(successor (plus (predecessor x) y)))))
(define (scheme-int->my-int n)
(if (zero? n) (zero)
(successor (scheme-int->my-int (- n 1)))))
(define (my-int->scheme-int x)
(if (is-zero? x) 0
(+ 1 (my-int->scheme-int (predecessor x)))))
(equal??
(my-int->scheme-int
(plus
(scheme-int->my-int 3)
(scheme-int->my-int 7)))
10)
(report-unit-tests-completed 'reverse-number-representation)
)
)

57
collects/tests/eopl/chapter2/sec2.2-ds-rep.scm Executable file
View File

@ -0,0 +1,57 @@
(module sec2.2-ds-rep (lib "eopl.ss" "eopl")
;; Simple data structure representation of environments
;; Page: 38
(require "utils.scm")
;; data definition:
;; Env ::= (empty-env) | (extend-env Var Schemeval Env)
;; empty-env : () -> Env
(define empty-env
(lambda () (list 'empty-env)))
;; extend-env : Var * Schemeval * Env -> Env
(define extend-env
(lambda (var val env)
(list 'extend-env var val env)))
;; apply-env : Env * Var -> Schemeval
(define apply-env
(lambda (env search-var)
(cond
((eqv? (car env) 'empty-env)
(report-no-binding-found search-var))
((eqv? (car env) 'extend-env)
(let ((saved-var (cadr env))
(saved-val (caddr env))
(saved-env (cadddr env)))
(if (eqv? search-var saved-var)
saved-val
(apply-env saved-env search-var))))
(else
(report-invalid-env env)))))
(define report-no-binding-found
(lambda (search-var)
(eopl:error 'apply-env "No binding for ~s" search-var)))
(define report-invalid-env
(lambda (env)
(eopl:error 'apply-env "Bad environment: ~s" env)))
(define e
(extend-env 'd 6
(extend-env 'y 8
(extend-env 'x 7
(extend-env 'y 14
(empty-env))))))
(equal?? (apply-env e 'd) 6)
(equal?? (apply-env e 'y) 8)
(equal?? (apply-env e 'x) 7)
(report-unit-tests-completed 'apply-env)
)

53
collects/tests/eopl/chapter2/sec2.2-proc-rep.scm Executable file
View File

@ -0,0 +1,53 @@
(module sec2.2-proc-rep (lib "eopl.ss" "eopl")
;; Simple procedural representation of environments
;; Page: 40
(require "utils.scm")
;; data definition:
;; Env = Var -> Schemeval
;; empty-env : () -> Env
(define empty-env
(lambda ()
(lambda (search-var)
(report-no-binding-found search-var))))
;; extend-env : Var * Schemeval * Env -> Env
(define extend-env
(lambda (saved-var saved-val saved-env)
(lambda (search-var)
(if (eqv? search-var saved-var)
saved-val
(apply-env saved-env search-var)))))
;; apply-env : Env * Var -> Schemeval
(define apply-env
(lambda (env search-var)
(env search-var)))
(define report-no-binding-found
(lambda (search-var)
(eopl:error 'apply-env "No binding for ~s" search-var)))
(define report-invalid-env
(lambda (env)
(eopl:error 'apply-env "Bad environment: ~s" env)))
(define e
(extend-env 'd 6
(extend-env 'y 8
(extend-env 'x 7
(extend-env 'y 14
(empty-env))))))
(equal?? (apply-env e 'd) 6)
(equal?? (apply-env e 'y) 8)
(equal?? (apply-env e 'x) 7)
(report-unit-tests-completed 'apply-env)
)

85
collects/tests/eopl/chapter2/sec2.3.scm Executable file
View File

@ -0,0 +1,85 @@
(module sec2.3 (lib "eopl.ss" "eopl")
(require "utils.scm")
;; var-exp : Var -> Lc-exp
(define var-exp
(lambda (var)
`(var-exp ,var)))
;; lambda-exp : Var * Lc-exp -> Lc-exp
(define lambda-exp
(lambda (var lc-exp)
`(lambda-exp ,var ,lc-exp)))
;; app-exp : Lc-exp * Lc-exp -> Lc-exp
(define app-exp
(lambda (lc-exp1 lc-exp2)
`(app-exp ,lc-exp1 ,lc-exp2)))
;; var-exp? : Lc-exp -> Bool
(define var-exp?
(lambda (x)
(and (pair? x) (eq? (car x) 'var-exp))))
;; lambda-exp? : Lc-exp -> Bool
(define lambda-exp?
(lambda (x)
(and (pair? x) (eq? (car x) 'lambda-exp))))
;; app-exp? : Lc-exp -> Bool
(define app-exp?
(lambda (x)
(and (pair? x) (eq? (car x) 'app-exp))))
;; var-exp->var : Lc-exp -> Var
(define var-exp->var
(lambda (x)
(cadr x)))
;; lambda-exp->bound-var : Lc-exp -> Var
(define lambda-exp->bound-var
(lambda (x)
(cadr x)))
;; lambda-exp->body : Lc-exp -> Lc-exp
(define lambda-exp->body
(lambda (x)
(caddr x)))
;; app-exp->rator : Lc-exp -> Lc-exp
(define app-exp->rator
(lambda (x)
(cadr x)))
;; app-exp->rand : Lc-exp -> Lc-exp
(define app-exp->rand
(lambda (x)
(caddr x)))
;; occurs-free? : Sym * Lcexp -> Bool
(define occurs-free?
(lambda (search-var exp)
(cond
((var-exp? exp) (eqv? search-var (var-exp->var exp)))
((lambda-exp? exp)
(and
(not (eqv? search-var (lambda-exp->bound-var exp)))
(occurs-free? search-var (lambda-exp->body exp))))
(else
(or
(occurs-free? search-var (app-exp->rator exp))
(occurs-free? search-var (app-exp->rand exp)))))))
;; a few small unit tests
(equal??
(occurs-free? 'a (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a))))
#f)
(equal??
(occurs-free? 'b (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a))))
#t)
(report-unit-tests-completed 'occurs-free?)
)

114
collects/tests/eopl/chapter2/sec2.4.scm Executable file
View File

@ -0,0 +1,114 @@
(module sec2.4 (lib "eopl.ss" "eopl")
(require "utils.scm")
(define identifier? symbol?)
(define-datatype lc-exp lc-exp?
(var-exp
(var identifier?))
(lambda-exp
(bound-var identifier?)
(body lc-exp?))
(app-exp
(rator lc-exp?)
(rand lc-exp?)))
;; occurs-free? : Sym * Lcexp -> Bool
(define occurs-free?
(lambda (search-var exp)
(cases lc-exp exp
(var-exp (var) (eqv? var search-var))
(lambda-exp (bound-var body)
(and
(not (eqv? search-var bound-var))
(occurs-free? search-var body)))
(app-exp (rator rand)
(or
(occurs-free? search-var rator)
(occurs-free? search-var rand))))))
;; test items
(equal?? (occurs-free? 'x (var-exp 'x)) #t)
(equal?? (occurs-free? 'x (var-exp 'y)) #f)
(equal?? (occurs-free? 'x (lambda-exp 'x
(app-exp (var-exp 'x) (var-exp 'y))))
#f)
(equal??
(occurs-free? 'x (lambda-exp 'y
(app-exp (var-exp 'x) (var-exp 'y))))
#t)
(equal??
(occurs-free? 'x
(app-exp
(lambda-exp 'x (var-exp 'x))
(app-exp (var-exp 'x) (var-exp 'y))))
#t)
(equal??
(occurs-free? 'x
(lambda-exp 'y
(lambda-exp 'z
(app-exp (var-exp 'x)
(app-exp (var-exp 'y) (var-exp 'z))))))
#t)
(define-datatype s-list s-list?
(empty-s-list)
(non-empty-s-list
(first s-exp?)
(rest s-list?)))
(define-datatype s-exp s-exp?
(symbol-s-exp
(sym symbol?))
(s-list-s-exp
(slst s-list?)))
;; page 48: alternate definition
(define-datatype s-list-alt s-list-alt?
(an-s-list
(sexps (list-of s-exp?))))
(define list-of
(lambda (pred)
(lambda (val)
(or (null? val)
(and (pair? val)
(pred (car val))
((list-of pred) (cdr val)))))))
;; For exercises 2.24-2.25
(define-datatype bintree bintree?
(leaf-node
(num integer?))
(interior-node
(key symbol?)
(left bintree?)
(right bintree?)))
;; > (bintree-to-list
;; (interior-node
;; 'a
;; (leaf-node 3)
;; (leaf-node 4)))
;; (interior-node a (leaf-node 3) (leaf-node 4)))
;; > (define tree-1
;; (interior-node 'foo (leaf-node 2) (leaf-node 3)))
;; > (define tree-2
;; (interior-node 'bar (leaf-node -1) tree-1))
;; > (define tree-3
;; (interior-node 'baz tree-2 (leaf-node 1)))
;; > (max-interior tree-2)
;; foo
;; > (max-interior tree-3)
;; baz
(eopl:printf "unit tests completed successfully.~%")
)

150
collects/tests/eopl/chapter2/sec2.5.scm Executable file
View File

@ -0,0 +1,150 @@
(module sec2.5 (lib "eopl.ss" "eopl")
(require "utils.scm")
;; data definitions
(define identifier? symbol?)
(define-datatype lc-exp lc-exp?
(var-exp
(var identifier?))
(lambda-exp
(bound-var identifier?)
(body lc-exp?))
(app-exp
(rator lc-exp?)
(rand lc-exp?)))
;; parse-expression : Schemeval -> Lcexp
;; page 53
(define parse-expression
(lambda (datum)
(cond
((symbol? datum) (var-exp datum))
((pair? datum)
(if (eqv? (car datum) 'lambda)
(lambda-exp
(car (cadr datum))
(parse-expression (caddr datum)))
(app-exp
(parse-expression (car datum))
(parse-expression (cadr datum)))))
(else (report-invalid-concrete-syntax datum)))))
(define report-invalid-concrete-syntax
(lambda (datum)
(eopl:error "invalid concrete syntax ~s" datum)))
;; unit tests
(equal??
(parse-expression 'x)
(var-exp 'x))
(equal??
(parse-expression 'y)
(var-exp 'y))
(equal??
(parse-expression '(lambda (x) (x y)))
(lambda-exp 'x
(app-exp (var-exp 'x) (var-exp 'y))))
(equal??
(parse-expression '(lambda (y) (x y)))
(lambda-exp 'y (app-exp (var-exp 'x) (var-exp 'y))))
(equal??
(parse-expression '((lambda (x) x) (x y)))
(app-exp
(lambda-exp 'x (var-exp 'x))
(app-exp (var-exp 'x) (var-exp 'y))))
(equal??
(parse-expression '(lambda (y) (lambda (z) (x (y z)))))
(lambda-exp 'y
(lambda-exp 'z
(app-exp (var-exp 'x)
(app-exp (var-exp 'y) (var-exp 'z))))))
(report-unit-tests-completed 'parse-expression)
;; unparse-lc-exp : Lcexp -> Schemeval
;; page 53
(define unparse-lc-exp
(lambda (exp)
(cases lc-exp exp
(var-exp (var) var)
(lambda-exp (bound-var body)
(list 'lambda (list bound-var)
(unparse-lc-exp body)))
(app-exp (rator rand)
(list
(unparse-lc-exp rator) (unparse-lc-exp rand))))))
;; unit tests
(equal??
(unparse-lc-exp (var-exp 'x))
'x)
(equal??
(unparse-lc-exp (var-exp 'y))
'y)
(equal??
(unparse-lc-exp
(lambda-exp 'x (app-exp (var-exp 'x) (var-exp 'y))))
'(lambda (x) (x y)))
(equal??
(unparse-lc-exp
(lambda-exp 'y (app-exp (var-exp 'x) (var-exp 'y))))
'(lambda (y) (x y)))
(equal??
(unparse-lc-exp
(app-exp
(lambda-exp 'x (var-exp 'x))
(app-exp (var-exp 'x) (var-exp 'y))))
'((lambda (x) x) (x y)))
(equal??
(unparse-lc-exp
(lambda-exp 'y
(lambda-exp 'z
(app-exp (var-exp 'x)
(app-exp (var-exp 'y) (var-exp 'z))))))
'(lambda (y) (lambda (z) (x (y z)))))
(report-unit-tests-completed 'unparse-lc-exp)
;; Exercise 2.27
;; ((lambda (a) (a b)) c)
;; (lambda (x)
;; (lambda (y)
;; ((lambda (x)
;; (x y))
;; x)))
;; Exercise 2.31
(define-datatype prefix-exp prefix-exp?
(const-exp
(num integer?))
(diff-exp
(operand1 prefix-exp?)
(operand2 prefix-exp?)))
;; (diff-exp
;; (diff-exp
;; (const-exp 3)
;; (const-exp 2))
;; (diff-exp
;; (const-exp 4)
;; (diff-exp
;; (const-exp 12)
;; (const-exp 7))))
)

20
collects/tests/eopl/chapter2/utils.scm Executable file
View File

@ -0,0 +1,20 @@
(module utils (lib "eopl.ss" "eopl")
;; a very simple macro for inline testing
(provide equal?? report-unit-tests-completed)
;; simple-minded magic for tests
(define-syntax equal??
(syntax-rules ()
((_ x y)
(let ((x^ x) (y^ y))
(if (not (equal? x y))
(eopl:error 'equal??
"~s is not equal to ~s" 'x 'y))))))
(define report-unit-tests-completed
(lambda (fn-name)
(eopl:printf "unit tests completed: ~s~%" fn-name)))
)

74
collects/tests/eopl/chapter3/let-lang/data-structures.scm Executable file
View File

@ -0,0 +1,74 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for let-lang.
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean or a procval.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?)))
;;; extractors:
;; expval->num : ExpVal -> Int
;; Page: 70
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
;; expval->bool : ExpVal -> Bool
;; Page: 70
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;;
;; example of a data type built without define-datatype
(define empty-env-record
(lambda ()
'()))
(define extended-env-record
(lambda (sym val old-env)
(cons (list sym val) old-env)))
(define empty-env-record? null?)
(define environment?
(lambda (x)
(or (empty-env-record? x)
(and (pair? x)
(symbol? (car (car x)))
(expval? (cadr (car x)))
(environment? (cdr x))))))
(define extended-env-record->sym
(lambda (r)
(car (car r))))
(define extended-env-record->val
(lambda (r)
(cadr (car r))))
(define extended-env-record->old-env
(lambda (r)
(cdr r)))
)

130
collects/tests/eopl/chapter3/let-lang/drscheme-init.scm Executable file
View File

@ -0,0 +1,130 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

54
collects/tests/eopl/chapter3/let-lang/environments.scm Executable file
View File

@ -0,0 +1,54 @@
(module environments (lib "eopl.ss" "eopl")
;; builds environment interface, using data structures defined in
;; data-structures.scm.
(require "data-structures.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; usage: (init-env) = [i=1, v=5, x=10]
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
;; Page: 69
(define init-env
(lambda ()
(extend-env
'i (num-val 1)
(extend-env
'v (num-val 5)
(extend-env
'x (num-val 10)
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define empty-env
(lambda ()
(empty-env-record)))
(define empty-env?
(lambda (x)
(empty-env-record? x)))
(define extend-env
(lambda (sym val old-env)
(extended-env-record sym val old-env)))
(define apply-env
(lambda (env search-sym)
(if (empty-env? env)
(eopl:error 'apply-env "No binding for ~s" search-sym)
(let ((sym (extended-env-record->sym env))
(val (extended-env-record->val env))
(old-env (extended-env-record->old-env env)))
(if (eqv? search-sym sym)
val
(apply-env old-env search-sym))))))
)

71
collects/tests/eopl/chapter3/let-lang/interp.scm Executable file
View File

@ -0,0 +1,71 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the LET language. The \commentboxes are the
;; latex code for inserting the rules into the code in the book.
;; These are too complicated to put here, see the text, sorry.
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(provide value-of-program value-of)
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
;; Page: 71
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 71
(define value-of
(lambda (exp env)
(cases expression exp
;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}}
(const-exp (num) (num-val num))
;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})}
(var-exp (var) (apply-env env var))
;\commentbox{\diffspec}
(diff-exp (exp1 exp2)
(let ((val1 (value-of exp1 env))
(val2 (value-of exp2 env)))
(let ((num1 (expval->num val1))
(num2 (expval->num val2)))
(num-val
(- num1 num2)))))
;\commentbox{\zerotestspec}
(zero?-exp (exp1)
(let ((val1 (value-of exp1 env)))
(let ((num1 (expval->num val1)))
(if (zero? num1)
(bool-val #t)
(bool-val #f)))))
;\commentbox{\ma{\theifspec}}
(if-exp (exp1 exp2 exp3)
(let ((val1 (value-of exp1 env)))
(if (expval->bool val1)
(value-of exp2 env)
(value-of exp3 env))))
;\commentbox{\ma{\theletspecsplit}}
(let-exp (var exp1 body)
(let ((val1 (value-of exp1 env)))
(value-of body
(extend-env var val1 env))))
)))
)

60
collects/tests/eopl/chapter3/let-lang/lang.scm Executable file
View File

@ -0,0 +1,60 @@
(module lang
;; grammar for the LET language
(lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

59
collects/tests/eopl/chapter3/let-lang/tests.scm Executable file
View File

@ -0,0 +1,59 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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)
))
)

73
collects/tests/eopl/chapter3/let-lang/top.scm Executable file
View File

@ -0,0 +1,73 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
;; since this is the top-level module, we don't really need to
;; provide anything, but we do so just in case.
(provide run run-all)
;; here are some other things that could be provided:
;; (provide (all-defined))
;; (provide (all-from "interp.scm"))
;; (provide (all-from "lang.scm"))
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
;; Page: 71
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : symbol -> expval
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

72
collects/tests/eopl/chapter3/letrec-lang/data-structures.scm Executable file
View File

@ -0,0 +1,72 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for letrec-lang.
(require "lang.scm") ; for expression?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean or a procval.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?)))
;;; extractors:
;; expval->num : ExpVal -> Int
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
;; expval->bool : ExpVal -> Bool
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
;; expval->proc : ExpVal -> Proc
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
;; proc? : SchemeVal -> Bool
;; procedure : Var * Exp * Env -> Proc
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
;; Page: 86
(define-datatype environment environment?
(empty-env)
(extend-env
(bvar symbol?)
(bval expval?)
(saved-env environment?))
(extend-env-rec
(id symbol?)
(bvar symbol?)
(body expression?)
(saved-env environment?)))
)

129
collects/tests/eopl/chapter3/letrec-lang/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

46
collects/tests/eopl/chapter3/letrec-lang/environments.scm Executable file
View File

@ -0,0 +1,46 @@
(module environments (lib "eopl.ss" "eopl")
;; builds environment interface, using data structures defined in
;; data-structures.scm.
(require "data-structures.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; usage: (init-env) = [i=1, v=5, x=10]
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
;; Page: 69
(define init-env
(lambda ()
(extend-env
'i (num-val 1)
(extend-env
'v (num-val 5)
(extend-env
'x (num-val 10)
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
;; Page: 86
(define apply-env
(lambda (env search-sym)
(cases environment env
(empty-env ()
(eopl:error 'apply-env "No binding for ~s" search-sym))
(extend-env (var val saved-env)
(if (eqv? search-sym var)
val
(apply-env saved-env search-sym)))
(extend-env-rec (p-name b-var p-body saved-env)
(if (eqv? search-sym p-name)
(proc-val (procedure b-var p-body env))
(apply-env saved-env search-sym))))))
)

92
collects/tests/eopl/chapter3/letrec-lang/interp.scm Executable file
View File

@ -0,0 +1,92 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the LETREC language. The \commentboxes are the
;; latex code for inserting the rules into the code in the book.
;; These are too complicated to put here, see the text, sorry.
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(provide value-of-program value-of)
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 83
(define value-of
(lambda (exp env)
(cases expression exp
;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}}
(const-exp (num) (num-val num))
;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})}
(var-exp (var) (apply-env env var))
;\commentbox{\diffspec}
(diff-exp (exp1 exp2)
(let ((val1 (value-of exp1 env))
(val2 (value-of exp2 env)))
(let ((num1 (expval->num val1))
(num2 (expval->num val2)))
(num-val
(- num1 num2)))))
;\commentbox{\zerotestspec}
(zero?-exp (exp1)
(let ((val1 (value-of exp1 env)))
(let ((num1 (expval->num val1)))
(if (zero? num1)
(bool-val #t)
(bool-val #f)))))
;\commentbox{\ma{\theifspec}}
(if-exp (exp1 exp2 exp3)
(let ((val1 (value-of exp1 env)))
(if (expval->bool val1)
(value-of exp2 env)
(value-of exp3 env))))
;\commentbox{\ma{\theletspecsplit}}
(let-exp (var exp1 body)
(let ((val1 (value-of exp1 env)))
(value-of body
(extend-env var val1 env))))
(proc-exp (var body)
(proc-val (procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of rand env)))
(apply-procedure proc arg)))
(letrec-exp (p-name b-var p-body letrec-body)
(value-of letrec-body
(extend-env-rec p-name b-var p-body env)))
)))
;; apply-procedure : Proc * ExpVal -> ExpVal
(define apply-procedure
(lambda (proc1 arg)
(cases proc proc1
(procedure (var body saved-env)
(value-of body (extend-env var arg saved-env))))))
)

72
collects/tests/eopl/chapter3/letrec-lang/lang.scm Executable file
View File

@ -0,0 +1,72 @@
(module lang (lib "eopl.ss" "eopl")
;; grammar for the LETREC language
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("letrec"
identifier "(" identifier ")" "=" expression
"in" expression)
letrec-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

101
collects/tests/eopl/chapter3/letrec-lang/tests.scm Executable file
View File

@ -0,0 +1,101 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) 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 f(x) = -(x,1) in (f 33)" 32)
(simple-letrec-2
"letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
8)
(simple-letrec-3
"let m = -5
in letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), m) in (f 4)"
20)
;; alas, no multiplication in this language. Exercise: define
;; multiplication as a letrec and then use it to define factorial.
;; (fact-of-6 "letrec
;; fact(x) = if zero?(x) then 1 else *(x, (fact sub1(x)))
;; in (fact 6)"
;; 720)
(HO-nested-letrecs
"letrec even(odd) = proc(x) if zero?(x) then 1 else (odd -(x,1))
in letrec odd(x) = if zero?(x) then 0 else ((even odd) -(x,1))
in (odd 13)" 1)
))
)

66
collects/tests/eopl/chapter3/letrec-lang/top.scm Executable file
View File

@ -0,0 +1,66 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
;; since this is the top-level module, we don't really need to
;; provide anything, but we do so just in case.
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

94
collects/tests/eopl/chapter3/lexaddr-lang/data-structures.scm Executable file
View File

@ -0,0 +1,94 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for LEXADDR language
(require "lang.scm") ; for expression?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean or a procval.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?)))
;;; extractors:
;; expval->num : ExpVal -> Int
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
;; expval->bool : ExpVal -> Bool
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
;; expval->proc : ExpVal -> Proc
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
;; proc? : SchemeVal -> Bool
;; procedure : Exp * Nameless-env -> Proc
(define-datatype proc proc?
(procedure
;; in LEXADDR, bound variables are replaced by %nameless-vars, so
;; there is no need to declare bound variables.
;; (bvar symbol?)
(body expression?)
;; and the closure contains a nameless environment
(env nameless-environment?)))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
;; nameless-environment? : SchemeVal -> Bool
;; Page: 99
(define nameless-environment?
(lambda (x)
((list-of expval?) x)))
;; empty-nameless-env : () -> Nameless-env
;; Page: 99
(define empty-nameless-env
(lambda ()
'()))
;; empty-nameless-env? : Nameless-env -> Bool
(define empty-nameless-env?
(lambda (x)
(null? x)))
;; extend-nameless-env : ExpVal * Nameless-env -> Nameless-env
;; Page: 99
(define extend-nameless-env
(lambda (val nameless-env)
(cons val nameless-env)))
;; apply-nameless-env : Nameless-env * Lexaddr -> ExpVal
;; Page: 99
(define apply-nameless-env
(lambda (nameless-env n)
(list-ref nameless-env n)))
)

129
collects/tests/eopl/chapter3/lexaddr-lang/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

26
collects/tests/eopl/chapter3/lexaddr-lang/environments.scm Executable file
View File

@ -0,0 +1,26 @@
(module environments (lib "eopl.ss" "eopl")
(require "data-structures.scm")
(provide init-nameless-env empty-nameless-env extend-nameless-env
apply-nameless-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Nameless-env
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
(define init-nameless-env
(lambda ()
(extend-nameless-env
(num-val 1) ; was i
(extend-nameless-env
(num-val 5) ; was v
(extend-nameless-env
(num-val 10) ; was x
(empty-nameless-env))))))
)

90
collects/tests/eopl/chapter3/lexaddr-lang/interp.scm Executable file
View File

@ -0,0 +1,90 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the LEXADDR language.
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(provide value-of-translation value-of)
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-translation : Nameless-program -> ExpVal
(define value-of-translation
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-nameless-env))))))
;; value-of-translation : Nameless-program -> ExpVal
;; Page: 100
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-nameless-env))))))
;; value-of : Nameless-exp * Nameless-env -> ExpVal
(define value-of
(lambda (exp nameless-env)
(cases expression exp
(const-exp (num) (num-val num))
(diff-exp (exp1 exp2)
(let ((val1
(expval->num
(value-of exp1 nameless-env)))
(val2
(expval->num
(value-of exp2 nameless-env))))
(num-val
(- val1 val2))))
(zero?-exp (exp1)
(let ((val1 (expval->num (value-of exp1 nameless-env))))
(if (zero? val1)
(bool-val #t)
(bool-val #f))))
(if-exp (exp0 exp1 exp2)
(if (expval->bool (value-of exp0 nameless-env))
(value-of exp1 nameless-env)
(value-of exp2 nameless-env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator nameless-env)))
(arg (value-of rand nameless-env)))
(apply-procedure proc arg)))
(nameless-var-exp (n)
(apply-nameless-env nameless-env n))
(nameless-let-exp (exp1 body)
(let ((val (value-of exp1 nameless-env)))
(value-of body
(extend-nameless-env val nameless-env))))
(nameless-proc-exp (body)
(proc-val
(procedure body nameless-env)))
(else
(eopl:error 'value-of
"Illegal expression in translated code: ~s" exp))
)))
;; apply-procedure : Proc * ExpVal -> ExpVal
(define apply-procedure
(lambda (proc1 arg)
(cases proc proc1
(procedure (body saved-env)
(value-of body (extend-nameless-env arg saved-env))))))
)

76
collects/tests/eopl/chapter3/lexaddr-lang/lang.scm Executable file
View File

@ -0,0 +1,76 @@
(module lang
;; grammar for the LEXADDR language
(lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression ("%nameless-var" number) nameless-var-exp)
(expression
("%let" expression "in" expression)
nameless-let-exp)
(expression
("%lexproc" expression)
nameless-proc-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

78
collects/tests/eopl/chapter3/lexaddr-lang/tests.scm Executable file
View File

@ -0,0 +1,78 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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)
; these aren't translatable. Exercise: make them translatable by
; providing a binding for foo.
; ;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4)
in let times4 = (fix t4m)
in (times4 3)" 12)
))
)

67
collects/tests/eopl/chapter3/lexaddr-lang/top.scm Executable file
View File

@ -0,0 +1,67 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(require "translator.scm") ; for translation-of-program
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
;; Page: 98
(define run
(lambda (string)
(value-of-translation
(translation-of-program
(scan&parse string)))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

100
collects/tests/eopl/chapter3/lexaddr-lang/translator.scm Executable file
View File

@ -0,0 +1,100 @@
(module translator (lib "eopl.ss" "eopl")
(require "lang.scm")
(provide translation-of-program)
;;;;;;;;;;;;;;;; lexical address calculator ;;;;;;;;;;;;;;;;
;; translation-of-program : Program -> Nameless-program
;; Page: 96
(define translation-of-program
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(a-program
(translation-of exp1 (init-senv)))))))
;; translation-of : Exp * Senv -> Nameless-exp
;; Page 97
(define translation-of
(lambda (exp senv)
(cases expression exp
(const-exp (num) (const-exp num))
(diff-exp (exp1 exp2)
(diff-exp
(translation-of exp1 senv)
(translation-of exp2 senv)))
(zero?-exp (exp1)
(zero?-exp
(translation-of exp1 senv)))
(if-exp (exp1 exp2 exp3)
(if-exp
(translation-of exp1 senv)
(translation-of exp2 senv)
(translation-of exp3 senv)))
(var-exp (var)
(nameless-var-exp
(apply-senv senv var)))
(let-exp (var exp1 body)
(nameless-let-exp
(translation-of exp1 senv)
(translation-of body
(extend-senv var senv))))
(proc-exp (var body)
(nameless-proc-exp
(translation-of body
(extend-senv var senv))))
(call-exp (rator rand)
(call-exp
(translation-of rator senv)
(translation-of rand senv)))
(else (report-invalid-source-expression exp))
)))
(define report-invalid-source-expression
(lambda (exp)
(eopl:error 'value-of
"Illegal expression in source code: ~s" exp)))
;;;;;;;;;;;;;;;; static environments ;;;;;;;;;;;;;;;;
;;; Senv = Listof(Sym)
;;; Lexaddr = N
;; empty-senv : () -> Senv
;; Page: 95
(define empty-senv
(lambda ()
'()))
;; extend-senv : Var * Senv -> Senv
;; Page: 95
(define extend-senv
(lambda (var senv)
(cons var senv)))
;; apply-senv : Senv * Var -> Lexaddr
;; Page: 95
(define apply-senv
(lambda (senv var)
(cond
((null? senv) (report-unbound-var var))
((eqv? var (car senv))
0)
(else
(+ 1 (apply-senv (cdr senv) var))))))
(define report-unbound-var
(lambda (var)
(eopl:error 'translation-of "unbound variable in code: ~s" var)))
;; init-senv : () -> Senv
;; Page: 96
(define init-senv
(lambda ()
(extend-senv 'i
(extend-senv 'v
(extend-senv 'x
(empty-senv))))))
)

93
collects/tests/eopl/chapter3/proc-lang/ds-rep/data-structures.scm Executable file
View File

@ -0,0 +1,93 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for proc-lang/ds-rep
(require "lang.scm") ; for expression?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean or a procval.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?)))
;;; extractors:
;; expval->num : ExpVal -> Int
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
;; expval->bool : ExpVal -> Bool
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
;; expval->proc : ExpVal -> Proc
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
;; proc? : SchemeVal -> Bool
;; procedure : Var * Exp * Env -> Proc
(define-datatype proc proc?
(procedure
(var symbol?)
(body expression?)
(env environment?)))
;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;;
;; example of a data type built without define-datatype
(define empty-env-record
(lambda ()
'()))
(define extended-env-record
(lambda (sym val old-env)
(cons (list sym val) old-env)))
(define empty-env-record? null?)
(define environment?
(lambda (x)
(or (empty-env-record? x)
(and (pair? x)
(symbol? (car (car x)))
(expval? (cadr (car x)))
(environment? (cdr x))))))
(define extended-env-record->sym
(lambda (r)
(car (car r))))
(define extended-env-record->val
(lambda (r)
(cadr (car r))))
(define extended-env-record->old-env
(lambda (r)
(cdr r)))
)

129
collects/tests/eopl/chapter3/proc-lang/ds-rep/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

53
collects/tests/eopl/chapter3/proc-lang/ds-rep/environments.scm Executable file
View File

@ -0,0 +1,53 @@
(module environments (lib "eopl.ss" "eopl")
;; builds environment interface, using data structures defined in
;; data-structures.scm.
(require "data-structures.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; usage: (init-env) = [i=1, v=5, x=10]
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
;; Page: 69
(define init-env
(lambda ()
(extend-env
'i (num-val 1)
(extend-env
'v (num-val 5)
(extend-env
'x (num-val 10)
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define empty-env
(lambda ()
(empty-env-record)))
(define empty-env?
(lambda (x)
(empty-env-record? x)))
(define extend-env
(lambda (sym val old-env)
(extended-env-record sym val old-env)))
(define apply-env
(lambda (env search-sym)
(if (empty-env? env)
(eopl:error 'apply-env "No binding for ~s" search-sym)
(let ((sym (extended-env-record->sym env))
(val (extended-env-record->val env))
(old-env (extended-env-record->old-env env)))
(if (eqv? search-sym sym)
val
(apply-env old-env search-sym))))))
)

86
collects/tests/eopl/chapter3/proc-lang/ds-rep/interp.scm Executable file
View File

@ -0,0 +1,86 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the PROC language, using the data structure
;; representation of procedures.
;; The \commentboxes are the latex code for inserting the rules into
;; the code in the book. These are too complicated to put here, see
;; the text, sorry.
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(provide value-of-program value-of)
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-env))))))
;; value-of : Exp * Env -> ExpVal
(define value-of
(lambda (exp env)
(cases expression exp
;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}}
(const-exp (num) (num-val num))
;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})}
(var-exp (var) (apply-env env var))
;\commentbox{\diffspec}
(diff-exp (exp1 exp2)
(let ((val1 (value-of exp1 env))
(val2 (value-of exp2 env)))
(let ((num1 (expval->num val1))
(num2 (expval->num val2)))
(num-val
(- num1 num2)))))
;\commentbox{\zerotestspec}
(zero?-exp (exp1)
(let ((val1 (value-of exp1 env)))
(let ((num1 (expval->num val1)))
(if (zero? num1)
(bool-val #t)
(bool-val #f)))))
;\commentbox{\ma{\theifspec}}
(if-exp (exp1 exp2 exp3)
(let ((val1 (value-of exp1 env)))
(if (expval->bool val1)
(value-of exp2 env)
(value-of exp3 env))))
;\commentbox{\ma{\theletspecsplit}}
(let-exp (var exp1 body)
(let ((val1 (value-of exp1 env)))
(value-of body
(extend-env var val1 env))))
(proc-exp (var body)
(proc-val (procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of rand env)))
(apply-procedure proc arg)))
)))
;; apply-procedure : Proc * ExpVal -> ExpVal
;; Page: 79
(define apply-procedure
(lambda (proc1 val)
(cases proc proc1
(procedure (var body saved-env)
(value-of body (extend-env var val saved-env))))))
)

66
collects/tests/eopl/chapter3/proc-lang/ds-rep/lang.scm Executable file
View File

@ -0,0 +1,66 @@
(module lang (lib "eopl.ss" "eopl")
;; grammar for the PROC language
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

77
collects/tests/eopl/chapter3/proc-lang/ds-rep/tests.scm Executable file
View File

@ -0,0 +1,77 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4)
in let times4 = (fix t4m)
in (times4 3)" 12)
))
)

59
collects/tests/eopl/chapter3/proc-lang/ds-rep/top.scm Executable file
View File

@ -0,0 +1,59 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

89
collects/tests/eopl/chapter3/proc-lang/proc-rep/data-structures.scm Executable file
View File

@ -0,0 +1,89 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for proc-lang/proc-rep
(require "lang.scm") ; for expression?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean or a procval.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?)))
;;; extractors:
;; expval->num : ExpVal -> Int
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
;; expval->bool : ExpVal -> Bool
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
;; expval->proc : ExpVal -> Proc
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
;; proc? : SchemeVal -> Bool
;; Page: 79
(define proc? procedure?)
;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;;
;; example of a data type built without define-datatype
(define empty-env-record
(lambda ()
'()))
(define extended-env-record
(lambda (sym val old-env)
(cons (list sym val) old-env)))
(define empty-env-record? null?)
(define environment?
(lambda (x)
(or (empty-env-record? x)
(and (pair? x)
(symbol? (car (car x)))
(expval? (cadr (car x)))
(environment? (cdr x))))))
(define extended-env-record->sym
(lambda (r)
(car (car r))))
(define extended-env-record->val
(lambda (r)
(cadr (car r))))
(define extended-env-record->old-env
(lambda (r)
(cdr r)))
)

129
collects/tests/eopl/chapter3/proc-lang/proc-rep/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

53
collects/tests/eopl/chapter3/proc-lang/proc-rep/environments.scm Executable file
View File

@ -0,0 +1,53 @@
(module environments (lib "eopl.ss" "eopl")
;; builds environment interface, using data structures defined in
;; data-structures.scm.
(require "data-structures.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; usage: (init-env) = [i=1, v=5, x=10]
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
;; Page: 69
(define init-env
(lambda ()
(extend-env
'i (num-val 1)
(extend-env
'v (num-val 5)
(extend-env
'x (num-val 10)
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define empty-env
(lambda ()
(empty-env-record)))
(define empty-env?
(lambda (x)
(empty-env-record? x)))
(define extend-env
(lambda (sym val old-env)
(extended-env-record sym val old-env)))
(define apply-env
(lambda (env search-sym)
(if (empty-env? env)
(eopl:error 'apply-env "No binding for ~s" search-sym)
(let ((sym (extended-env-record->sym env))
(val (extended-env-record->val env))
(old-env (extended-env-record->old-env env)))
(if (eqv? search-sym sym)
val
(apply-env old-env search-sym))))))
)

92
collects/tests/eopl/chapter3/proc-lang/proc-rep/interp.scm Executable file
View File

@ -0,0 +1,92 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the PROC language, using the procedural
;; representation of procedures.
;; The \commentboxes are the latex code for inserting the rules into
;; the code in the book. These are too complicated to put here, see
;; the text, sorry.
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(provide value-of-program value-of)
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-env))))))
;; value-of : Exp * Env -> ExpVal
(define value-of
(lambda (exp env)
(cases expression exp
;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}}
(const-exp (num) (num-val num))
;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})}
(var-exp (var) (apply-env env var))
;\commentbox{\diffspec}
(diff-exp (exp1 exp2)
(let ((val1 (value-of exp1 env))
(val2 (value-of exp2 env)))
(let ((num1 (expval->num val1))
(num2 (expval->num val2)))
(num-val
(- num1 num2)))))
;\commentbox{\zerotestspec}
(zero?-exp (exp1)
(let ((val1 (value-of exp1 env)))
(let ((num1 (expval->num val1)))
(if (zero? num1)
(bool-val #t)
(bool-val #f)))))
;\commentbox{\ma{\theifspec}}
(if-exp (exp1 exp2 exp3)
(let ((val1 (value-of exp1 env)))
(if (expval->bool val1)
(value-of exp2 env)
(value-of exp3 env))))
;\commentbox{\ma{\theletspecsplit}}
(let-exp (var exp1 body)
(let ((val1 (value-of exp1 env)))
(value-of body
(extend-env var val1 env))))
(proc-exp (var body)
(proc-val (procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of rand env)))
(apply-procedure proc arg)))
)))
;; procedure : Var * Exp * Env -> Proc
;; Page: 79
(define procedure
(lambda (var body env)
(lambda (val)
(value-of body (extend-env var val env)))))
;; apply-procedure : Proc * ExpVal -> ExpVal
;; Page: 79
(define apply-procedure
(lambda (proc val)
(proc val)))
)

66
collects/tests/eopl/chapter3/proc-lang/proc-rep/lang.scm Executable file
View File

@ -0,0 +1,66 @@
(module lang (lib "eopl.ss" "eopl")
;; grammar for the PROC language
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

78
collects/tests/eopl/chapter3/proc-lang/proc-rep/tests.scm Executable file
View File

@ -0,0 +1,78 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4)
in let times4 = (fix t4m)
in (times4 3)" 12)
))
)

64
collects/tests/eopl/chapter3/proc-lang/proc-rep/top.scm Executable file
View File

@ -0,0 +1,64 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : string -> expval
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : symbol -> expval
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

126
collects/tests/eopl/chapter4/call-by-need/data-structures.scm Executable file
View File

@ -0,0 +1,126 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for call-by-need language
(require "lang.scm") ; for expression?
(require "store.scm") ; for reference?
(require "pairvals.scm")
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean, a procval, a
;;; reference, or a mutable pair.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?))
(ref-val
(ref reference?))
(mutpair-val
(p mutpair?))
)
;;; extractors:
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval->ref
(lambda (v)
(cases expval v
(ref-val (ref) ref)
(else (expval-extractor-error 'reference v)))))
(define expval->mutpair
(lambda (v)
(cases expval v
(mutpair-val (ref) ref)
(else (expval-extractor-error 'mutable-pair v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
;;;;;;;;;;;;;;;; environment data structures ;;;;;;;;;;;;;;;;
(define-datatype environment environment?
(empty-env)
(extend-env
(bvar symbol?)
(bval reference?)
(saved-env environment?))
(extend-env-rec*
(proc-names (list-of symbol?))
(b-vars (list-of symbol?))
(proc-bodies (list-of expression?))
(saved-env environment?)))
;; env->list : Env -> List
;; used for pretty-printing and debugging
(define env->list
(lambda (env)
(cases environment env
(empty-env () '())
(extend-env (sym val saved-env)
(cons
(list sym val) ; val is a denoted value-- a
; reference.
(env->list saved-env)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cons
(list 'letrec p-names '...)
(env->list saved-env))))))
;; expval->printable : ExpVal -> List
;; returns a value like its argument, except procedures get cleaned
;; up with env->list
(define expval->printable
(lambda (val)
(cases expval val
(proc-val (p)
(cases proc p
(procedure (var body saved-env)
(list 'procedure var '... (env->list saved-env)))))
(else val))))
;;;;;;;;;;;;;;;; thunks ;;;;;;;;;;;;;;;;
;; a-thunk : Exp * Env -> Thunk
;; thunk? : SchemeVal -> Bool
(define-datatype thunk thunk?
(a-thunk
(exp1 expression?)
(env environment?)))
)

129
collects/tests/eopl/chapter4/call-by-need/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

67
collects/tests/eopl/chapter4/call-by-need/environments.scm Executable file
View File

@ -0,0 +1,67 @@
(module environments (lib "eopl.ss" "eopl")
;; builds environment interface, using data structures defined in
;; data-structures.scm.
(require "data-structures.scm")
(require "store.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; (init-env) builds an environment in which:
;; i is bound to a location containing the expressed value 1,
;; v is bound to a location containing the expressed value 5, and
;; x is bound to a location containing the expressed value 10.
(define init-env
(lambda ()
(extend-env
'i (newref (num-val 1))
(extend-env
'v (newref (num-val 5))
(extend-env
'x (newref (num-val 10))
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define apply-env
(lambda (env search-sym)
(cases environment env
(empty-env ()
(eopl:error 'apply-env "No binding for ~s" search-sym))
(extend-env (bvar bval saved-env)
(if (eqv? search-sym bvar)
bval
(apply-env saved-env search-sym)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cond
((location search-sym p-names)
=> (lambda (n)
(newref
(proc-val
(procedure
(list-ref b-vars n)
(list-ref p-bodies n)
env)))))
(else (apply-env saved-env search-sym)))))))
;; location : Sym * Listof(Sym) -> Maybe(Int)
;; (location sym syms) returns the location of sym in syms or #f is
;; sym is not in syms. We can specify this as follows:
;; if (memv sym syms)
;; then (list-ref syms (location sym syms)) = sym
;; else (location sym syms) = #f
(define location
(lambda (sym syms)
(cond
((null? syms) #f)
((eqv? sym (car syms)) 0)
((location sym (cdr syms))
=> (lambda (n)
(+ n 1)))
(else #f))))
)

167
collects/tests/eopl/chapter4/call-by-need/interp.scm Executable file
View File

@ -0,0 +1,167 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the CALL-BY-NEED language.
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(require "store.scm")
(require "pairvals.scm")
(provide value-of-program value-of instrument-newref)
;;; exercise: add instrumentation around let and procedure calls, as
;;; in the call-by-reference language.
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(initialize-store!)
(cases program pgm
(a-program (body)
(value-of body (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 137 and 138
(define value-of
(lambda (exp env)
(cases expression exp
(const-exp (num) (num-val num))
(var-exp (var)
(let ((ref1 (apply-env env var)))
(let ((w (deref ref1)))
(if (expval? w)
w
(let ((v1 (value-of-thunk w)))
(begin
(setref! ref1 v1)
v1))))))
(diff-exp (exp1 exp2)
(let ((val1
(expval->num
(value-of exp1 env)))
(val2
(expval->num
(value-of exp2 env))))
(num-val
(- val1 val2))))
(zero?-exp (exp1)
(let ((val1 (expval->num (value-of exp1 env))))
(if (zero? val1)
(bool-val #t)
(bool-val #f))))
(if-exp (exp0 exp1 exp2)
(if (expval->bool (value-of exp0 env))
(value-of exp1 env)
(value-of exp2 env)))
(let-exp (var exp1 body)
(let ((val (value-of exp1 env)))
(value-of body
(extend-env var (newref val) env))))
(proc-exp (var body)
(proc-val
(procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of-operand rand env)))
(apply-procedure proc arg)))
(letrec-exp (p-names b-vars p-bodies letrec-body)
(value-of letrec-body
(extend-env-rec* p-names b-vars p-bodies env)))
(begin-exp (exp1 exps)
(letrec
((value-of-begins
(lambda (e1 es)
(let ((v1 (value-of e1 env)))
(if (null? es)
v1
(value-of-begins (car es) (cdr es)))))))
(value-of-begins exp1 exps)))
(assign-exp (x e)
(begin
(setref!
(apply-env env x)
(value-of e env))
(num-val 27)))
(newpair-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(mutpair-val (make-pair v1 v2))))
(left-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((p1 (expval->mutpair v1)))
(left p1))))
(setleft-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(let ((p (expval->mutpair v1)))
(begin
(setleft p v2)
(num-val 82)))))
(right-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((p1 (expval->mutpair v1)))
(right p1))))
(setright-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(let ((p (expval->mutpair v1)))
(begin
(setright p v2)
(num-val 83)))))
)))
;; apply-procedure : Proc * Ref -> ExpVal
(define apply-procedure
(lambda (proc1 arg)
(cases proc proc1
(procedure (var body saved-env)
(value-of body
(extend-env var arg saved-env))))))
;; value-of-operand : Exp * Env -> Ref
;; Page: 137
(define value-of-operand
(lambda (exp env)
(cases expression exp
(var-exp (var) (apply-env env var)) ; no deref!
(else
(newref (a-thunk exp env))))))
;; value-of-thunk : Thunk -> ExpVal
(define value-of-thunk
(lambda (th)
(cases thunk th
(a-thunk (exp1 saved-env)
(value-of exp1 saved-env)))))
)

101
collects/tests/eopl/chapter4/call-by-need/lang.scm Executable file
View File

@ -0,0 +1,101 @@
(module lang (lib "eopl.ss" "eopl")
;; language for the CALL-BY-NEED language. Based on MUTABLE-PAIRS
;; language.
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("letrec"
(arbno identifier "(" identifier ")" "=" expression)
"in" expression)
letrec-exp)
(expression
("begin" expression (arbno ";" expression) "end")
begin-exp)
(expression
("set" identifier "=" expression)
assign-exp)
(expression
("newpair" "(" expression "," expression ")")
newpair-exp)
(expression
("left" "(" expression ")")
left-exp)
(expression
("setleft" expression "=" expression)
setleft-exp)
(expression
("right" "(" expression ")")
right-exp)
(expression
("setright" expression "=" expression)
setright-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

58
collects/tests/eopl/chapter4/call-by-need/pairval1.scm Executable file
View File

@ -0,0 +1,58 @@
(module pairval1 (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "store.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;;
;; represent a mutable pair as two references.
;; Page: 124
(define-datatype mutpair mutpair?
(a-pair
(left-loc reference?)
(right-loc reference?)))
;; make-pair : ExpVal * ExpVal -> MutPair
;; Page: 124
(define make-pair
(lambda (val1 val2)
(a-pair
(newref val1)
(newref val2))))
;; left : MutPair -> ExpVal
;; Page: 125
(define left
(lambda (p)
(cases mutpair p
(a-pair (left-loc right-loc)
(deref left-loc)))))
;; right : MutPair -> ExpVal
;; Page: 125
(define right
(lambda (p)
(cases mutpair p
(a-pair (left-loc right-loc)
(deref right-loc)))))
;; setleft : MutPair * ExpVal -> Unspecified
;; Page: 125
(define setleft
(lambda (p val)
(cases mutpair p
(a-pair (left-loc right-loc)
(setref! left-loc val)))))
;; setright : MutPair * ExpVal -> Unspecified
;; Page: 125
(define setright
(lambda (p val)
(cases mutpair p
(a-pair (left-loc right-loc)
(setref! right-loc val)))))
)

81
collects/tests/eopl/chapter4/call-by-need/pairval2.scm Executable file
View File

@ -0,0 +1,81 @@
(module pairval2 (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "store.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;;
;; model a mutable pair as two consecutive locations (left and
;; right), and represent it as a reference to the first.
;; mutpair? : SchemeVal -> Bool
;; Page: 129
;;
;; Not every reference is really a mutpair, but this test is good
;; enough, because in the implicit-refs language, you
;; can't get your hands on a reference otherwise.
(define mutpair?
(lambda (v)
(reference? v)))
;; make-pair : ExpVal * ExpVal -> MutPair
;; Page: 129
(define make-pair
(lambda (val1 val2)
(let ((ref1 (newref val1)))
(let ((ref2 (newref val2)))
ref1))))
;; left : MutPair -> ExpVal
;; Page: 129
(define left
(lambda (p)
(deref p)))
;; right : MutPair -> ExpVal
;; Page: 129
(define right
(lambda (p)
(deref (+ 1 p))))
;; setleft : MutPair * ExpVal -> Unspecified
;; Page: 129
(define setleft
(lambda (p val)
(setref! p val)))
;; setright : MutPair * Expval -> Unspecified
;; Page: 129
(define setright
(lambda (p val)
(setref! (+ 1 p) val)))
)
;; (define mutpair? reference?) ; inaccurate
;; (define make-pair
;; (lambda (val1 val2)
;; (let ((ref1 (newref val1)))
;; (let ((ref2 (newref val2))) ; guaranteed to be ref1 + 1
;; ref1))))
;; (define left
;; (lambda (p)
;; (deref p)))
;; (define right
;; (lambda (p)
;; (deref (+ 1 p))))
;; (define setleft
;; (lambda (p val)
;; (setref! p val)))
;; (define setright
;; (lambda (p val)
;; (setref! (+ 1 p) val)))

12
collects/tests/eopl/chapter4/call-by-need/pairvals.scm Executable file
View File

@ -0,0 +1,12 @@
(module pairvals (lib "eopl.ss" "eopl")
;; choose one of the following:
;; (require "pairval1.scm")
;; (provide (all-from "pairval1.scm"))
;; or
(require "pairval2.scm")
(provide (all-from "pairval2.scm"))
)

113
collects/tests/eopl/chapter4/call-by-need/store.scm Executable file
View File

@ -0,0 +1,113 @@
(module store (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
;(require "data-structures.scm")
(provide initialize-store! reference? newref deref setref!
instrument-newref get-store-as-list)
(define instrument-newref (make-parameter #f))
;;;;;;;;;;;;;;;; references and the store ;;;;;;;;;;;;;;;;
;;; world's dumbest model of the store: the store is a list and a
;;; reference is number which denotes a position in the list.
;; the-store: a Scheme variable containing the current state of the
;; store. Initially set to a dummy variable.
(define the-store 'uninitialized)
;; empty-store : () -> Sto
;; Page: 111
(define empty-store
(lambda () '()))
;; initialize-store! : () -> Sto
;; usage: (initialize-store!) sets the-store to the empty-store
;; Page 111
(define initialize-store!
(lambda ()
(set! the-store (empty-store))))
;; get-store : () -> Sto
;; Page: 111
;; This is obsolete. Replaced by get-store-as-list below
(define get-store
(lambda () the-store))
;; reference? : SchemeVal -> Bool
;; Page: 111
(define reference?
(lambda (v)
(integer? v)))
;; newref : ExpVal -> Ref
;; Page: 111
(define newref
(lambda (val)
(let ((next-ref (length the-store)))
(set! the-store
(append the-store (list val)))
(if (instrument-newref)
(eopl:printf
"newref: allocating location ~s with initial contents ~s~%"
next-ref val))
next-ref)))
;; deref : Ref -> ExpVal
;; Page 111
(define deref
(lambda (ref)
(list-ref the-store ref)))
;; setref! : Ref * ExpVal -> Unspecified
;; Page: 112
(define setref!
(lambda (ref val)
(set! the-store
(letrec
((setref-inner
;; returns a list like store1, except that position ref1
;; contains val.
(lambda (store1 ref1)
(cond
((null? store1)
(report-invalid-reference ref the-store))
((zero? ref1)
(cons val (cdr store1)))
(else
(cons
(car store1)
(setref-inner
(cdr store1) (- ref1 1))))))))
(setref-inner the-store ref)))))
(define report-invalid-reference
(lambda (ref the-store)
(eopl:error 'setref
"illegal reference ~s in store ~s"
ref the-store)))
;; get-store-as-list : () -> Listof(List(Ref,Expval))
;; Exports the current state of the store as a scheme list.
;; (get-store-as-list '(foo bar baz)) = ((0 foo)(1 bar) (2 baz))
;; where foo, bar, and baz are expvals.
;; If the store were represented in a different way, this would be
;; replaced by something cleverer.
;; Replaces get-store (p. 111)
(define get-store-as-list
(lambda ()
(letrec
((inner-loop
;; convert sto to list as if its car was location n
(lambda (sto n)
(if (null? sto)
'()
(cons
(list n (car sto))
(inner-loop (cdr sto) (+ n 1)))))))
(inner-loop the-store 0))))
)

169
collects/tests/eopl/chapter4/call-by-need/tests.scm Executable file
View File

@ -0,0 +1,169 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) 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 f(x) = -(x,1) in (f 33)" 32)
(simple-letrec-2
"letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
8)
(simple-letrec-3
"let m = -5
in letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), m) in (f 4)"
20)
;; alas, no multiplication in this language. Exercise: define
;; multiplication as a letrec and then use it to define factorial.
;; (fact-of-6 "letrec
;; fact(x) = if zero?(x) then 1 else *(x, (fact sub1(x)))
;; in (fact 6)"
;; 720)
(HO-nested-letrecs
"letrec even(odd) = proc(x) if zero?(x) then 1 else (odd -(x,1))
in letrec odd(x) = if zero?(x) then 0 else ((even odd) -(x,1))
in (odd 13)" 1)
(begin-test-1
"begin 1; 2; 3 end"
3)
;; extremely primitive testing for mutable variables
(assignment-test-1 "let x = 17
in begin set x = 27; x end"
27)
(gensym-test
"let g = let count = 0 in proc(d)
let d = set count = -(count,-1)
in count
in -((g 11), (g 22))"
-1)
(even-odd-via-set "
let x = 0
in letrec even(d) = if zero?(x) then 1
else let d = set x = -(x,1)
in (odd d)
odd(d) = if zero?(x) then 0
else let d = set x = -(x,1)
in (even d)
in let d = set x = 13 in (odd -99)" 1)
;; even more primitive testing for mutable pairs
(simple-mutpair-left-1 "let p = newpair(22,33) in left(p)" 22)
(simple-mutpair-right-1 "let p = newpair(22,33) in right(p)" 33)
(simple-mutpair-setleft-1 "
let p = newpair(22,33) in begin setleft p = 77; left(p) end" 77)
(simple-mutpair-setleft-2 "
let p = newpair(22,33) in begin setleft p = 77; right(p) end" 33)
(simple-mutpair-setright-1 "
let p = newpair(22,33) in begin setright p = 77; right(p) end" 77)
(simple-mutpair-setright-2 "
let p = newpair(22,33) in begin setright p = 77; left(p) end" 22)
(gensym-using-mutable-pair-left
"let g = let count = newpair(0,0)
in proc (dummy)
begin
setleft count = -(left(count), -1);
left(count)
end
in -((g 22), (g 22))"
-1)
(gensym-using-mutable-pair-right
"let g = let count = newpair(0,0)
in proc (dummy)
begin
setright count = -(right(count), -1);
right(count)
end
in -((g 22), (g 22))"
-1)
))
)

63
collects/tests/eopl/chapter4/call-by-need/top.scm Executable file
View File

@ -0,0 +1,63 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

117
collects/tests/eopl/chapter4/call-by-reference/data-structures.scm Executable file
View File

@ -0,0 +1,117 @@
(module data-structures (lib "eopl.ss" "eopl")
;; data structures for call-by-reference language
(require "lang.scm") ; for expression?
(require "store.scm") ; for reference?
(require "pairvals.scm")
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean, a procval, a
;;; reference, or a mutable pair.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?))
(ref-val
(ref reference?))
(mutpair-val
(p mutpair?))
)
;;; extractors:
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval->ref
(lambda (v)
(cases expval v
(ref-val (ref) ref)
(else (expval-extractor-error 'reference v)))))
(define expval->mutpair
(lambda (v)
(cases expval v
(mutpair-val (ref) ref)
(else (expval-extractor-error 'mutable-pair v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
;;;;;;;;;;;;;;;; environment data structures ;;;;;;;;;;;;;;;;
(define-datatype environment environment?
(empty-env)
(extend-env
(bvar symbol?)
(bval reference?)
(saved-env environment?))
(extend-env-rec*
(proc-names (list-of symbol?))
(b-vars (list-of symbol?))
(proc-bodies (list-of expression?))
(saved-env environment?)))
;; env->list : Env -> List
;; used for pretty-printing and debugging
(define env->list
(lambda (env)
(cases environment env
(empty-env () '())
(extend-env (sym val saved-env)
(cons
(list sym val) ; val is a denoted value-- a
; reference.
(env->list saved-env)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cons
(list 'letrec p-names '...)
(env->list saved-env))))))
;; expval->printable : ExpVal -> List
;; returns a value like its argument, except procedures get cleaned
;; up with env->list
(define expval->printable
(lambda (val)
(cases expval val
(proc-val (p)
(cases proc p
(procedure (var body saved-env)
(list 'procedure var '... (env->list saved-env)))))
(else val))))
)

129
collects/tests/eopl/chapter4/call-by-reference/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

64
collects/tests/eopl/chapter4/call-by-reference/environments.scm Executable file
View File

@ -0,0 +1,64 @@
(module environments (lib "eopl.ss" "eopl")
(require "data-structures.scm")
(require "store.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; (init-env) builds an environment in which:
;; i is bound to a location containing the expressed value 1,
;; v is bound to a location containing the expressed value 5, and
;; x is bound to a location containing the expressed value 10.
(define init-env
(lambda ()
(extend-env
'i (newref (num-val 1))
(extend-env
'v (newref (num-val 5))
(extend-env
'x (newref (num-val 10))
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define apply-env
(lambda (env search-sym)
(cases environment env
(empty-env ()
(eopl:error 'apply-env "No binding for ~s" search-sym))
(extend-env (bvar bval saved-env)
(if (eqv? search-sym bvar)
bval
(apply-env saved-env search-sym)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cond
((location search-sym p-names)
=> (lambda (n)
(newref
(proc-val
(procedure
(list-ref b-vars n)
(list-ref p-bodies n)
env)))))
(else (apply-env saved-env search-sym)))))))
;; location : Sym * Listof(Sym) -> Maybe(Int)
;; (location sym syms) returns the location of sym in syms or #f is
;; sym is not in syms. We can specify this as follows:
;; if (memv sym syms)
;; then (list-ref syms (location sym syms)) = sym
;; else (location sym syms) = #f
(define location
(lambda (sym syms)
(cond
((null? syms) #f)
((eqv? sym (car syms)) 0)
((location sym (cdr syms))
=> (lambda (n)
(+ n 1)))
(else #f))))
)

208
collects/tests/eopl/chapter4/call-by-reference/interp.scm Executable file
View File

@ -0,0 +1,208 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the CALL-BY-REFERENCE language
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(require "store.scm")
(require "pairvals.scm")
(provide value-of-program value-of instrument-let instrument-newref)
;;;;;;;;;;;;;;;; switches for instrument-let ;;;;;;;;;;;;;;;;
(define instrument-let (make-parameter #f))
;; say (instrument-let #t) to turn instrumentation on.
;; (instrument-let #f) to turn it off again.
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(initialize-store!)
(cases program pgm
(a-program (body)
(value-of body (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 132
(define value-of
(lambda (exp env)
(cases expression exp
(const-exp (num) (num-val num))
(var-exp (var) (deref (apply-env env var)))
(diff-exp (exp1 exp2)
(let ((val1
(expval->num
(value-of exp1 env)))
(val2
(expval->num
(value-of exp2 env))))
(num-val
(- val1 val2))))
(zero?-exp (exp1)
(let ((val1 (expval->num (value-of exp1 env))))
(if (zero? val1)
(bool-val #t)
(bool-val #f))))
(if-exp (exp0 exp1 exp2)
(if (expval->bool (value-of exp0 env))
(value-of exp1 env)
(value-of exp2 env)))
;; straightforward version of LET, without instrumentation
;; (let-exp (id rhs body)
;; (let ((val (value-of rhs env)))
;; (value-of body
;; (extend-env id (newref val) env))))
;; LET with instrumentation
(let-exp (var exp1 body)
(if (instrument-let)
(eopl:printf "entering let ~s~%" var))
(let ((val (value-of exp1 env)))
(let ((new-env (extend-env var (newref val) env)))
(if (instrument-let)
(begin
(eopl:printf "entering body of let ~s with env =~%" var)
(pretty-print (env->list new-env))
(eopl:printf "store =~%")
(pretty-print (store->readable (get-store-as-list)))
(eopl:printf "~%")
))
(value-of body new-env))))
(proc-exp (var body)
(proc-val
(procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of-operand rand env)))
(apply-procedure proc arg)))
(letrec-exp (p-names b-vars p-bodies letrec-body)
(value-of letrec-body
(extend-env-rec* p-names b-vars p-bodies env)))
(begin-exp (exp1 exps)
(letrec
((value-of-begins
(lambda (e1 es)
(let ((v1 (value-of e1 env)))
(if (null? es)
v1
(value-of-begins (car es) (cdr es)))))))
(value-of-begins exp1 exps)))
(assign-exp (x e)
(begin
(setref!
(apply-env env x)
(value-of e env))
(num-val 27)))
(newpair-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(mutpair-val (make-pair v1 v2))))
(left-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((p1 (expval->mutpair v1)))
(left p1))))
(setleft-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(let ((p (expval->mutpair v1)))
(begin
(setleft p v2)
(num-val 82)))))
(right-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((p1 (expval->mutpair v1)))
(right p1))))
(setright-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(let ((p (expval->mutpair v1)))
(begin
(setright p v2)
(num-val 83)))))
)))
;; apply-procedure : Proc * Ref -> ExpVal
;; uninstrumented version
;; Page: 132
;; (define apply-procedure
;; (lambda (proc1 val)
;; (cases proc proc1
;; (procedure (var body saved-env)
;; (value-of body
;; (extend-env var val saved-env))))))
;; apply-procedure : Proc * Ref -> ExpVal
;; instrumented version
(define apply-procedure
(lambda (proc1 val)
(cases proc proc1
(procedure (var body saved-env)
(let ((new-env (extend-env var val saved-env)))
(if (instrument-let)
(begin
(eopl:printf
"entering body of proc ~s with env =~%"
var)
(pretty-print (env->list new-env))
(eopl:printf "store =~%")
(pretty-print (store->readable (get-store-as-list)))
(eopl:printf "~%")))
(value-of body new-env))))))
;; value-of-rand : Exp * Env -> Ref
;; Page: 132
;; if the expression is a var-exp, then pass the reference.
;; otherwise, evaluate the expression and pass a reference to a new
;; cell.
(define value-of-operand
(lambda (exp env)
(cases expression exp
(var-exp (var) (apply-env env var))
(else
(newref (value-of exp env))))))
;; store->readable : Listof(List(Ref,Expval))
;; -> Listof(List(Ref,Something-Readable))
(define store->readable
(lambda (l)
(map
(lambda (p)
(list
(car p)
(expval->printable (cadr p))))
l)))
)

100
collects/tests/eopl/chapter4/call-by-reference/lang.scm Executable file
View File

@ -0,0 +1,100 @@
(module lang (lib "eopl.ss" "eopl")
;; language for CALL-BY-REFERENCE. Based on MUTABLE-PAIRS.
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("letrec"
(arbno identifier "(" identifier ")" "=" expression)
"in" expression)
letrec-exp)
(expression
("begin" expression (arbno ";" expression) "end")
begin-exp)
(expression
("set" identifier "=" expression)
assign-exp)
(expression
("newpair" "(" expression "," expression ")")
newpair-exp)
(expression
("left" "(" expression ")")
left-exp)
(expression
("setleft" expression "=" expression)
setleft-exp)
(expression
("right" "(" expression ")")
right-exp)
(expression
("setright" expression "=" expression)
setright-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

58
collects/tests/eopl/chapter4/call-by-reference/pairval1.scm Executable file
View File

@ -0,0 +1,58 @@
(module pairval1 (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "store.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;;
;; represent a mutable pair as two references.
;; Page: 124
(define-datatype mutpair mutpair?
(a-pair
(left-loc reference?)
(right-loc reference?)))
;; make-pair : ExpVal * ExpVal -> MutPair
;; Page: 124
(define make-pair
(lambda (val1 val2)
(a-pair
(newref val1)
(newref val2))))
;; left : MutPair -> ExpVal
;; Page: 125
(define left
(lambda (p)
(cases mutpair p
(a-pair (left-loc right-loc)
(deref left-loc)))))
;; right : MutPair -> ExpVal
;; Page: 125
(define right
(lambda (p)
(cases mutpair p
(a-pair (left-loc right-loc)
(deref right-loc)))))
;; setleft : MutPair * ExpVal -> Unspecified
;; Page: 125
(define setleft
(lambda (p val)
(cases mutpair p
(a-pair (left-loc right-loc)
(setref! left-loc val)))))
;; setright : MutPair * ExpVal -> Unspecified
;; Page: 125
(define setright
(lambda (p val)
(cases mutpair p
(a-pair (left-loc right-loc)
(setref! right-loc val)))))
)

81
collects/tests/eopl/chapter4/call-by-reference/pairval2.scm Executable file
View File

@ -0,0 +1,81 @@
(module pairval2 (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "store.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;;
;; model a mutable pair as two consecutive locations (left and
;; right), and represent it as a reference to the first.
;; mutpair? : SchemeVal -> Bool
;; Page: 129
;;
;; Not every reference is really a mutpair, but this test is good
;; enough, because in the implicit-refs language, you
;; can't get your hands on a reference otherwise.
(define mutpair?
(lambda (v)
(reference? v)))
;; make-pair : ExpVal * ExpVal -> MutPair
;; Page: 129
(define make-pair
(lambda (val1 val2)
(let ((ref1 (newref val1)))
(let ((ref2 (newref val2)))
ref1))))
;; left : MutPair -> ExpVal
;; Page: 129
(define left
(lambda (p)
(deref p)))
;; right : MutPair -> ExpVal
;; Page: 129
(define right
(lambda (p)
(deref (+ 1 p))))
;; setleft : MutPair * ExpVal -> Unspecified
;; Page: 129
(define setleft
(lambda (p val)
(setref! p val)))
;; setright : MutPair * Expval -> Unspecified
;; Page: 129
(define setright
(lambda (p val)
(setref! (+ 1 p) val)))
)
;; (define mutpair? reference?) ; inaccurate
;; (define make-pair
;; (lambda (val1 val2)
;; (let ((ref1 (newref val1)))
;; (let ((ref2 (newref val2))) ; guaranteed to be ref1 + 1
;; ref1))))
;; (define left
;; (lambda (p)
;; (deref p)))
;; (define right
;; (lambda (p)
;; (deref (+ 1 p))))
;; (define setleft
;; (lambda (p val)
;; (setref! p val)))
;; (define setright
;; (lambda (p val)
;; (setref! (+ 1 p) val)))

12
collects/tests/eopl/chapter4/call-by-reference/pairvals.scm Executable file
View File

@ -0,0 +1,12 @@
(module pairvals (lib "eopl.ss" "eopl")
;; choose one of the following:
;; (require "pairval1.scm")
;; (provide (all-from "pairval1.scm"))
;; or
(require "pairval2.scm")
(provide (all-from "pairval2.scm"))
)

113
collects/tests/eopl/chapter4/call-by-reference/store.scm Executable file
View File

@ -0,0 +1,113 @@
(module store (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
;(require "data-structures.scm")
(provide initialize-store! reference? newref deref setref!
instrument-newref get-store-as-list)
(define instrument-newref (make-parameter #f))
;;;;;;;;;;;;;;;; references and the store ;;;;;;;;;;;;;;;;
;;; world's dumbest model of the store: the store is a list and a
;;; reference is number which denotes a position in the list.
;; the-store: a Scheme variable containing the current state of the
;; store. Initially set to a dummy variable.
(define the-store 'uninitialized)
;; empty-store : () -> Sto
;; Page: 111
(define empty-store
(lambda () '()))
;; initialize-store! : () -> Sto
;; usage: (initialize-store!) sets the-store to the empty-store
;; Page 111
(define initialize-store!
(lambda ()
(set! the-store (empty-store))))
;; get-store : () -> Sto
;; Page: 111
;; This is obsolete. Replaced by get-store-as-list below
(define get-store
(lambda () the-store))
;; reference? : SchemeVal -> Bool
;; Page: 111
(define reference?
(lambda (v)
(integer? v)))
;; newref : ExpVal -> Ref
;; Page: 111
(define newref
(lambda (val)
(let ((next-ref (length the-store)))
(set! the-store
(append the-store (list val)))
(if (instrument-newref)
(eopl:printf
"newref: allocating location ~s with initial contents ~s~%"
next-ref val))
next-ref)))
;; deref : Ref -> ExpVal
;; Page 111
(define deref
(lambda (ref)
(list-ref the-store ref)))
;; setref! : Ref * ExpVal -> Unspecified
;; Page: 112
(define setref!
(lambda (ref val)
(set! the-store
(letrec
((setref-inner
;; returns a list like store1, except that position ref1
;; contains val.
(lambda (store1 ref1)
(cond
((null? store1)
(report-invalid-reference ref the-store))
((zero? ref1)
(cons val (cdr store1)))
(else
(cons
(car store1)
(setref-inner
(cdr store1) (- ref1 1))))))))
(setref-inner the-store ref)))))
(define report-invalid-reference
(lambda (ref the-store)
(eopl:error 'setref
"illegal reference ~s in store ~s"
ref the-store)))
;; get-store-as-list : () -> Listof(List(Ref,Expval))
;; Exports the current state of the store as a scheme list.
;; (get-store-as-list '(foo bar baz)) = ((0 foo)(1 bar) (2 baz))
;; where foo, bar, and baz are expvals.
;; If the store were represented in a different way, this would be
;; replaced by something cleverer.
;; Replaces get-store (p. 111)
(define get-store-as-list
(lambda ()
(letrec
((inner-loop
;; convert sto to list as if its car was location n
(lambda (sto n)
(if (null? sto)
'()
(cons
(list n (car sto))
(inner-loop (cdr sto) (+ n 1)))))))
(inner-loop the-store 0))))
)

240
collects/tests/eopl/chapter4/call-by-reference/tests.scm Executable file
View File

@ -0,0 +1,240 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) 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 f(x) = -(x,1) in (f 33)" 32)
(simple-letrec-2
"letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
8)
(simple-letrec-3
"let m = -5
in letrec f(x) = 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 even(odd) = proc(x) if zero?(x) then 1 else (odd -(x,1))
in letrec odd(x) = if zero?(x) then 0 else ((even odd) -(x,1))
in (odd 13)" 1)
(begin-test-1
"begin 1; 2; 3 end"
3)
(assignment-test-1 "let x = 17
in begin set x = 27; x end"
27)
(gensym-test
"let g = let count = 0 in proc(d)
let d = set count = -(count,-1)
in count
in -((g 11), (g 22))"
-1)
(even-odd-via-set "
let x = 0
in letrec even(d) = if zero?(x) then 1
else let d = set x = -(x,1)
in (odd d)
odd(d) = if zero?(x) then 0
else let d = set x = -(x,1)
in (even d)
in let d = set x = 13 in (odd -99)" 1)
(simple-mutpair-left-1 "let p = newpair(22,33) in left(p)" 22)
(simple-mutpair-right-1 "let p = newpair(22,33) in right(p)" 33)
(simple-mutpair-setleft-1 "
let p = newpair(22,33) in begin setleft p = 77; left(p) end" 77)
(simple-mutpair-setleft-2 "
let p = newpair(22,33) in begin setleft p = 77; right(p) end" 33)
(simple-mutpair-setright-1 "
let p = newpair(22,33) in begin setright p = 77; right(p) end" 77)
(simple-mutpair-setright-2 "
let p = newpair(22,33) in begin setright p = 77; left(p) end" 22)
(gensym-using-mutable-pair-left
"let g = let count = newpair(0,0)
in proc (dummy)
begin
setleft count = -(left(count), -1);
left(count)
end
in -((g 22), (g 22))"
-1)
(gensym-using-mutable-pair-right
"let g = let count = newpair(0,0)
in proc (dummy)
begin
setright count = -(right(count), -1);
right(count)
end
in -((g 22), (g 22))"
-1)
;; new for call-by-reference
(cbr-swap-1
"let swap = proc (x) proc (y)
let temp = x
in begin
set x = y;
set y = temp
end
in let a = 33
in let b = 44
in begin
((swap a) b);
-(a,b)
end"
11)
(cbr-global-aliasing-1
"let p = proc (z) set z = 44
in let x = 33
in begin (p x); x end"
44)
(cbr-direct-aliasing-1
"let p = proc (x) proc (y)
begin
set x = 44;
y
end
in let b = 33
in ((p b) b)"
44)
(cbr-indirect-aliasing-1
;; in this language, you can't return a reference.
"let p = proc (x) proc (y)
begin
set x = 44;
y
end
in let q = proc(z) z
in let b = 33
in ((p b) (q b))"
33)
(cbr-indirect-aliasing-2
;; in this language, you can't return a reference.
"let p = proc (x) proc (y)
begin
set x = 44;
y
end
in let q = proc(z) z
in let b = 33
in ((p (q b)) b)"
33)
(cbr-sideeffect-a-passed-structure-1
"let f = proc (x) setleft x = -(left(x),-1)
in let p = newpair (44,newpair(55,66))
in begin
(f right(p));
left(right(p))
end"
56)
(cbr-example-for-book "
let f = proc (x) set x = 44
in let g = proc (y) (f y)
in let z = 55
in begin
(g z);
z
end"
44)
))
)

64
collects/tests/eopl/chapter4/call-by-reference/top.scm Executable file
View File

@ -0,0 +1,64 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

103
collects/tests/eopl/chapter4/explicit-refs/data-structures.scm Executable file
View File

@ -0,0 +1,103 @@
(module data-structures (lib "eopl.ss" "eopl")
(require "lang.scm") ; for expression?
(require "store.scm") ; for reference?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean, a procval, or a
;;; reference.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?))
(ref-val
(ref reference?))
)
;;; extractors:
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval->ref
(lambda (v)
(cases expval v
(ref-val (ref) ref)
(else (expval-extractor-error 'reference v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
(define-datatype environment environment?
(empty-env)
(extend-env
(bvar symbol?)
(bval expval?)
(saved-env environment?))
(extend-env-rec*
(proc-names (list-of symbol?))
(b-vars (list-of symbol?))
(proc-bodies (list-of expression?))
(saved-env environment?)))
;; env->list : Env -> List
;; used for pretty-printing and debugging
(define env->list
(lambda (env)
(cases environment env
(empty-env () '())
(extend-env (sym val saved-env)
(cons
(list sym (expval->printable val))
(env->list saved-env)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cons
(list 'letrec p-names '...)
(env->list saved-env))))))
;; expval->printable : ExpVal -> List
;; returns a value like its argument, except procedures get cleaned
;; up with env->list
(define expval->printable
(lambda (val)
(cases expval val
(proc-val (p)
(cases proc p
(procedure (var body saved-env)
(list 'procedure var '... (env->list saved-env)))))
(else val))))
)

129
collects/tests/eopl/chapter4/explicit-refs/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

63
collects/tests/eopl/chapter4/explicit-refs/environments.scm Executable file
View File

@ -0,0 +1,63 @@
(module environments (lib "eopl.ss" "eopl")
(require "data-structures.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; usage: (init-env) = [i=1, v=5, x=10]
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
;; Page: 69
(define init-env
(lambda ()
(extend-env
'i (num-val 1)
(extend-env
'v (num-val 5)
(extend-env
'x (num-val 10)
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define apply-env
(lambda (env search-sym)
(cases environment env
(empty-env ()
(eopl:error 'apply-env "No binding for ~s" search-sym))
(extend-env (bvar bval saved-env)
(if (eqv? search-sym bvar)
bval
(apply-env saved-env search-sym)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cond
((location search-sym p-names)
=> (lambda (n)
(proc-val
(procedure
(list-ref b-vars n)
(list-ref p-bodies n)
env))))
(else (apply-env saved-env search-sym)))))))
;; location : Sym * Listof(Sym) -> Maybe(Int)
;; (location sym syms) returns the location of sym in syms or #f is
;; sym is not in syms. We can specify this as follows:
;; if (memv sym syms)
;; then (list-ref syms (location sym syms)) = sym
;; else (location sym syms) = #f
(define location
(lambda (sym syms)
(cond
((null? syms) #f)
((eqv? sym (car syms)) 0)
((location sym (cdr syms))
=> (lambda (n)
(+ n 1)))
(else #f))))
)

156
collects/tests/eopl/chapter4/explicit-refs/interp.scm Executable file
View File

@ -0,0 +1,156 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the EXPLICIT-REFS language
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(require "store.scm")
(provide value-of-program value-of instrument-let instrument-newref)
;;;;;;;;;;;;;;;; switches for instrument-let ;;;;;;;;;;;;;;;;
(define instrument-let (make-parameter #f))
;; say (instrument-let #t) to turn instrumentation on.
;; (instrument-let #f) to turn it off again.
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
;; Page: 110
(define value-of-program
(lambda (pgm)
(initialize-store!) ; new for explicit refs.
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 113
(define value-of
(lambda (exp env)
(cases expression exp
;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}}
(const-exp (num) (num-val num))
;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})}
(var-exp (var) (apply-env env var))
;\commentbox{\diffspec}
(diff-exp (exp1 exp2)
(let ((val1 (value-of exp1 env))
(val2 (value-of exp2 env)))
(let ((num1 (expval->num val1))
(num2 (expval->num val2)))
(num-val
(- num1 num2)))))
;\commentbox{\zerotestspec}
(zero?-exp (exp1)
(let ((val1 (value-of exp1 env)))
(let ((num1 (expval->num val1)))
(if (zero? num1)
(bool-val #t)
(bool-val #f)))))
;\commentbox{\ma{\theifspec}}
(if-exp (exp1 exp2 exp3)
(let ((val1 (value-of exp1 env)))
(if (expval->bool val1)
(value-of exp2 env)
(value-of exp3 env))))
;\commentbox{\ma{\theletspecsplit}}
(let-exp (var exp1 body)
(let ((val1 (value-of exp1 env)))
(value-of body
(extend-env var val1 env))))
(proc-exp (var body)
(proc-val (procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of rand env)))
(apply-procedure proc arg)))
(letrec-exp (p-names b-vars p-bodies letrec-body)
(value-of letrec-body
(extend-env-rec* p-names b-vars p-bodies env)))
(begin-exp (exp1 exps)
(letrec
((value-of-begins
(lambda (e1 es)
(let ((v1 (value-of e1 env)))
(if (null? es)
v1
(value-of-begins (car es) (cdr es)))))))
(value-of-begins exp1 exps)))
(newref-exp (exp1)
(let ((v1 (value-of exp1 env)))
(ref-val (newref v1))))
(deref-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((ref1 (expval->ref v1)))
(deref ref1))))
(setref-exp (exp1 exp2)
(let ((ref (expval->ref (value-of exp1 env))))
(let ((v2 (value-of exp2 env)))
(begin
(setref! ref v2)
(num-val 23)))))
)))
;; apply-procedure : Proc * ExpVal -> ExpVal
;;
;; uninstrumented version
;; (define apply-procedure
;; (lambda (proc1 arg)
;; (cases proc proc1
;; (procedure (bvar body saved-env)
;; (value-of body (extend-env bvar arg saved-env))))))
;; instrumented version
(define apply-procedure
(lambda (proc1 arg)
(cases proc proc1
(procedure (var body saved-env)
(let ((r arg))
(let ((new-env (extend-env var r saved-env)))
(if (instrument-let)
(begin
(eopl:printf
"entering body of proc ~s with env =~%"
var)
(pretty-print (env->list new-env))
(eopl:printf "store =~%")
(pretty-print (store->readable (get-store-as-list)))
(eopl:printf "~%")))
(value-of body new-env)))))))
;; store->readable : Listof(List(Ref,Expval))
;; -> Listof(List(Ref,Something-Readable))
(define store->readable
(lambda (l)
(map
(lambda (p)
(cons
(car p)
(expval->printable (cadr p))))
l)))
)

90
collects/tests/eopl/chapter4/explicit-refs/lang.scm Executable file
View File

@ -0,0 +1,90 @@
(module lang (lib "eopl.ss" "eopl")
;; language for EXPLICIT-REFS
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("letrec"
(arbno identifier "(" identifier ")" "=" expression)
"in" expression)
letrec-exp)
;; new for explicit-refs
(expression
("begin" expression (arbno ";" expression) "end")
begin-exp)
(expression
("newref" "(" expression ")")
newref-exp)
(expression
("deref" "(" expression ")")
deref-exp)
(expression
("setref" "(" expression "," expression ")")
setref-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

110
collects/tests/eopl/chapter4/explicit-refs/store.scm Executable file
View File

@ -0,0 +1,110 @@
(module store (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(provide initialize-store! reference? newref deref setref!
instrument-newref get-store-as-list)
(define instrument-newref (make-parameter #f))
;;;;;;;;;;;;;;;; references and the store ;;;;;;;;;;;;;;;;
;;; world's dumbest model of the store: the store is a list and a
;;; reference is number which denotes a position in the list.
;; the-store: a Scheme variable containing the current state of the
;; store. Initially set to a dummy variable.
(define the-store 'uninitialized)
;; empty-store : () -> Sto
;; Page: 111
(define empty-store
(lambda () '()))
;; initialize-store! : () -> Sto
;; usage: (initialize-store!) sets the-store to the empty-store
;; Page 111
(define initialize-store!
(lambda ()
(set! the-store (empty-store))))
;; get-store : () -> Sto
;; Page: 111
;; This is obsolete. Replaced by get-store-as-list below
(define get-store
(lambda () the-store))
;; reference? : SchemeVal -> Bool
;; Page: 111
(define reference?
(lambda (v)
(integer? v)))
;; newref : ExpVal -> Ref
;; Page: 111
(define newref
(lambda (val)
(let ((next-ref (length the-store)))
(set! the-store
(append the-store (list val)))
(if (instrument-newref)
(eopl:printf
"newref: allocating location ~s with initial contents ~s~%"
next-ref val))
next-ref)))
;; deref : Ref -> ExpVal
;; Page 111
(define deref
(lambda (ref)
(list-ref the-store ref)))
;; setref! : Ref * ExpVal -> Unspecified
;; Page: 112
(define setref!
(lambda (ref val)
(set! the-store
(letrec
((setref-inner
;; returns a list like store1, except that position ref1
;; contains val.
(lambda (store1 ref1)
(cond
((null? store1)
(report-invalid-reference ref the-store))
((zero? ref1)
(cons val (cdr store1)))
(else
(cons
(car store1)
(setref-inner
(cdr store1) (- ref1 1))))))))
(setref-inner the-store ref)))))
(define report-invalid-reference
(lambda (ref the-store)
(eopl:error 'setref
"illegal reference ~s in store ~s"
ref the-store)))
;; get-store-as-list : () -> Listof(List(Ref,Expval))
;; Exports the current state of the store as a scheme list.
;; (get-store-as-list '(foo bar baz)) = ((0 foo)(1 bar) (2 baz))
;; where foo, bar, and baz are expvals.
;; If the store were represented in a different way, this would be
;; replaced by something cleverer.
;; Replaces get-store (p. 111)
(define get-store-as-list
(lambda ()
(letrec
((inner-loop
;; convert sto to list as if its car was location n
(lambda (sto n)
(if (null? sto)
'()
(cons
(list n (car sto))
(inner-loop (cdr sto) (+ n 1)))))))
(inner-loop the-store 0))))
)

163
collects/tests/eopl/chapter4/explicit-refs/tests.scm Executable file
View File

@ -0,0 +1,163 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) 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 f(x) = -(x,1) in (f 33)" 32)
(simple-letrec-2
"letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
8)
(simple-letrec-3
"let m = -5
in letrec f(x) = 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 even(odd) = proc(x) if zero?(x) then 1 else (odd -(x,1))
in letrec odd(x) = if zero?(x) then 0 else ((even odd) -(x,1))
in (odd 13)" 1)
(begin-test-1
"begin 1; 2; 3 end"
3)
(gensym-test-1
"let g = let counter = newref(0)
in proc (dummy) let d = setref(counter, -(deref(counter),-1))
in deref(counter)
in -((g 11),(g 22))"
-1)
(simple-store-test-1 "let x = newref(17) in deref(x)" 17)
(assignment-test-1 "let x = newref(17)
in begin setref(x,27); deref(x) end"
27)
(gensym-test-2
"let g = let counter = newref(0)
in proc (dummy) begin
setref(counter, -(deref(counter),-1));
deref(counter)
end
in -((g 11),(g 22))"
-1)
(even-odd-via-set-1 "
let x = newref(0)
in letrec even(d) = if zero?(deref(x))
then 1
else let d = setref(x, -(deref(x),1))
in (odd d)
odd(d) = if zero?(deref(x))
then 0
else let d = setref(x, -(deref(x),1))
in (even d)
in let d = setref(x,13) in (odd -100)" 1)
(even-odd-via-set-1 "
let x = newref(0)
in letrec even(d) = if zero?(deref(x))
then 1
else let d = setref(x, -(deref(x),1))
in (odd d)
odd(d) = if zero?(deref(x))
then 0
else let d = setref(x, -(deref(x),1))
in (even d)
in let d = setref(x,13) in (odd -100)" 1)
(show-allocation-1 "
let x = newref(22)
in let f = proc (z) let zz = newref(-(z,deref(x))) in deref(zz)
in -((f 66), (f 55))"
11)
(chains-1 "
let x = newref(newref(0))
in begin
setref(deref(x), 11);
deref(deref(x))
end"
11)
))
)

64
collects/tests/eopl/chapter4/explicit-refs/top.scm Executable file
View File

@ -0,0 +1,64 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

103
collects/tests/eopl/chapter4/implicit-refs/data-structures.scm Executable file
View File

@ -0,0 +1,103 @@
(module data-structures (lib "eopl.ss" "eopl")
(require "lang.scm") ; for expression?
(require "store.scm") ; for reference?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean, a procval, or a
;;; reference.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?))
(ref-val
(ref reference?))
)
;;; extractors:
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval->ref
(lambda (v)
(cases expval v
(ref-val (ref) ref)
(else (expval-extractor-error 'reference v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
(define-datatype environment environment?
(empty-env)
(extend-env
(bvar symbol?)
(bval reference?) ; new for implicit-refs
(saved-env environment?))
(extend-env-rec*
(proc-names (list-of symbol?))
(b-vars (list-of symbol?))
(proc-bodies (list-of expression?))
(saved-env environment?)))
;; env->list : Env -> List
;; used for pretty-printing and debugging
(define env->list
(lambda (env)
(cases environment env
(empty-env () '())
(extend-env (sym val saved-env)
(cons
(list sym val) ; val is a denoted value-- a
; reference.
(env->list saved-env)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cons
(list 'letrec p-names '...)
(env->list saved-env))))))
;; expval->printable : ExpVal -> List
;; returns a value like its argument, except procedures get cleaned
;; up with env->list
(define expval->printable
(lambda (val)
(cases expval val
(proc-val (p)
(cases proc p
(procedure (var body saved-env)
(list 'procedure var '... (env->list saved-env)))))
(else val))))
)

129
collects/tests/eopl/chapter4/implicit-refs/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

63
collects/tests/eopl/chapter4/implicit-refs/environments.scm Executable file
View File

@ -0,0 +1,63 @@
(module environments (lib "eopl.ss" "eopl")
(require "data-structures.scm")
(require "store.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> Env
;; (init-env) builds an environment in which:
;; i is bound to a location containing the expressed value 1,
;; v is bound to a location containing the expressed value 5, and
;; x is bound to a location containing the expressed value 10.
(define init-env
(lambda ()
(extend-env
'i (newref (num-val 1))
(extend-env
'v (newref (num-val 5))
(extend-env
'x (newref (num-val 10))
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define apply-env
(lambda (env search-var)
(cases environment env
(empty-env ()
(eopl:error 'apply-env "No binding for ~s" search-var))
(extend-env (bvar bval saved-env)
(if (eqv? search-var bvar)
bval
(apply-env saved-env search-var)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(let ((n (location search-var p-names)))
;; n : (maybe int)
(if n
(newref
(proc-val
(procedure
(list-ref b-vars n)
(list-ref p-bodies n)
env)))
(apply-env saved-env search-var)))))))
;; location : Sym * Listof(Sym) -> Maybe(Int)
;; (location sym syms) returns the location of sym in syms or #f is
;; sym is not in syms. We can specify this as follows:
;; if (memv sym syms)
;; then (list-ref syms (location sym syms)) = sym
;; else (location sym syms) = #f
(define location
(lambda (sym syms)
(cond
((null? syms) #f)
((eqv? sym (car syms)) 0)
((location sym (cdr syms))
=> (lambda (n)
(+ n 1)))
(else #f))))
)

150
collects/tests/eopl/chapter4/implicit-refs/interp.scm Executable file
View File

@ -0,0 +1,150 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the IMPLICIT-REFS language
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(require "store.scm")
(provide value-of-program value-of instrument-let instrument-newref)
;;;;;;;;;;;;;;;; switches for instrument-let ;;;;;;;;;;;;;;;;
(define instrument-let (make-parameter #f))
;; say (instrument-let #t) to turn instrumentation on.
;; (instrument-let #f) to turn it off again.
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(initialize-store!)
(cases program pgm
(a-program (exp1)
(value-of exp1 (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 118, 119
(define value-of
(lambda (exp env)
(cases expression exp
;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}}
(const-exp (num) (num-val num))
;\commentbox{ (value-of (var-exp \x{}) \r)
; = (deref (apply-env \r \x{}))}
(var-exp (var) (deref (apply-env env var)))
;\commentbox{\diffspec}
(diff-exp (exp1 exp2)
(let ((val1 (value-of exp1 env))
(val2 (value-of exp2 env)))
(let ((num1 (expval->num val1))
(num2 (expval->num val2)))
(num-val
(- num1 num2)))))
;\commentbox{\zerotestspec}
(zero?-exp (exp1)
(let ((val1 (value-of exp1 env)))
(let ((num1 (expval->num val1)))
(if (zero? num1)
(bool-val #t)
(bool-val #f)))))
;\commentbox{\ma{\theifspec}}
(if-exp (exp1 exp2 exp3)
(let ((val1 (value-of exp1 env)))
(if (expval->bool val1)
(value-of exp2 env)
(value-of exp3 env))))
;\commentbox{\ma{\theletspecsplit}}
(let-exp (var exp1 body)
(let ((v1 (value-of exp1 env)))
(value-of body
(extend-env var (newref v1) env))))
(proc-exp (var body)
(proc-val (procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of rand env)))
(apply-procedure proc arg)))
(letrec-exp (p-names b-vars p-bodies letrec-body)
(value-of letrec-body
(extend-env-rec* p-names b-vars p-bodies env)))
(begin-exp (exp1 exps)
(letrec
((value-of-begins
(lambda (e1 es)
(let ((v1 (value-of e1 env)))
(if (null? es)
v1
(value-of-begins (car es) (cdr es)))))))
(value-of-begins exp1 exps)))
(assign-exp (var exp1)
(begin
(setref!
(apply-env env var)
(value-of exp1 env))
(num-val 27)))
)))
;; apply-procedure : Proc * ExpVal -> ExpVal
;; Page: 119
;; uninstrumented version
;; (define apply-procedure
;; (lambda (proc1 val)
;; (cases proc proc1
;; (procedure (var body saved-env)
;; (value-of body
;; (extend-env var (newref val) saved-env))))))
;; instrumented version
(define apply-procedure
(lambda (proc1 arg)
(cases proc proc1
(procedure (var body saved-env)
(let ((r (newref arg)))
(let ((new-env (extend-env var r saved-env)))
(if (instrument-let)
(begin
(eopl:printf
"entering body of proc ~s with env =~%"
var)
(pretty-print (env->list new-env))
(eopl:printf "store =~%")
(pretty-print (store->readable (get-store-as-list)))
(eopl:printf "~%")))
(value-of body new-env)))))))
;; store->readable : Listof(List(Ref,Expval))
;; -> Listof(List(Ref,Something-Readable))
(define store->readable
(lambda (l)
(map
(lambda (p)
(list
(car p)
(expval->printable (cadr p))))
l)))
)

82
collects/tests/eopl/chapter4/implicit-refs/lang.scm Executable file
View File

@ -0,0 +1,82 @@
(module lang (lib "eopl.ss" "eopl")
;; language for IMPLICIT-REFS
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("letrec"
(arbno identifier "(" identifier ")" "=" expression)
"in" expression)
letrec-exp)
(expression
("begin" expression (arbno ";" expression) "end")
begin-exp)
;; new for implicit-refs
(expression
("set" identifier "=" expression)
assign-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

110
collects/tests/eopl/chapter4/implicit-refs/store.scm Executable file
View File

@ -0,0 +1,110 @@
(module store (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(provide initialize-store! reference? newref deref setref!
instrument-newref get-store-as-list)
(define instrument-newref (make-parameter #f))
;;;;;;;;;;;;;;;; references and the store ;;;;;;;;;;;;;;;;
;;; world's dumbest model of the store: the store is a list and a
;;; reference is number which denotes a position in the list.
;; the-store: a Scheme variable containing the current state of the
;; store. Initially set to a dummy variable.
(define the-store 'uninitialized)
;; empty-store : () -> Sto
;; Page: 111
(define empty-store
(lambda () '()))
;; initialize-store! : () -> Sto
;; usage: (initialize-store!) sets the-store to the empty-store
;; Page 111
(define initialize-store!
(lambda ()
(set! the-store (empty-store))))
;; get-store : () -> Sto
;; Page: 111
;; This is obsolete. Replaced by get-store-as-list below
(define get-store
(lambda () the-store))
;; reference? : SchemeVal -> Bool
;; Page: 111
(define reference?
(lambda (v)
(integer? v)))
;; newref : ExpVal -> Ref
;; Page: 111
(define newref
(lambda (val)
(let ((next-ref (length the-store)))
(set! the-store
(append the-store (list val)))
(if (instrument-newref)
(eopl:printf
"newref: allocating location ~s with initial contents ~s~%"
next-ref val))
next-ref)))
;; deref : Ref -> ExpVal
;; Page 111
(define deref
(lambda (ref)
(list-ref the-store ref)))
;; setref! : Ref * ExpVal -> Unspecified
;; Page: 112
(define setref!
(lambda (ref val)
(set! the-store
(letrec
((setref-inner
;; returns a list like store1, except that position ref1
;; contains val.
(lambda (store1 ref1)
(cond
((null? store1)
(report-invalid-reference ref the-store))
((zero? ref1)
(cons val (cdr store1)))
(else
(cons
(car store1)
(setref-inner
(cdr store1) (- ref1 1))))))))
(setref-inner the-store ref)))))
(define report-invalid-reference
(lambda (ref the-store)
(eopl:error 'setref
"illegal reference ~s in store ~s"
ref the-store)))
;; get-store-as-list : () -> Listof(List(Ref,Expval))
;; Exports the current state of the store as a scheme list.
;; (get-store-as-list '(foo bar baz)) = ((0 foo)(1 bar) (2 baz))
;; where foo, bar, and baz are expvals.
;; If the store were represented in a different way, this would be
;; replaced by something cleverer.
;; Replaces get-store (p. 111)
(define get-store-as-list
(lambda ()
(letrec
((inner-loop
;; convert sto to list as if its car was location n
(lambda (sto n)
(if (null? sto)
'()
(cons
(list n (car sto))
(inner-loop (cdr sto) (+ n 1)))))))
(inner-loop the-store 0))))
)

136
collects/tests/eopl/chapter4/implicit-refs/tests.scm Executable file
View File

@ -0,0 +1,136 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) 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 f(x) = -(x,1) in (f 33)" 32)
(simple-letrec-2
"letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
8)
(simple-letrec-3
"let m = -5
in letrec f(x) = 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 even(odd) = proc(x) if zero?(x) then 1 else (odd -(x,1))
in letrec odd(x) = if zero?(x) then 0 else ((even odd) -(x,1))
in (odd 13)" 1)
(begin-test-1
"begin 1; 2; 3 end"
3)
;; extremely primitive testing for mutable variables
(assignment-test-1 "let x = 17
in begin set x = 27; x end"
27)
(gensym-test
"let g = let count = 0 in proc(d)
let d = set count = -(count,-1)
in count
in -((g 11), (g 22))"
-1)
(even-odd-via-set "
let x = 0
in letrec even(d) = if zero?(x) then 1
else let d = set x = -(x,1)
in (odd d)
odd(d) = if zero?(x) then 0
else let d = set x = -(x,1)
in (even d)
in let d = set x = 13 in (odd -99)" 1)
(example-for-book-1 "
let f = proc (x) proc (y)
begin
set x = -(x,-1);
-(x,y)
end
in ((f 44) 33)"
12)
))
)

62
collects/tests/eopl/chapter4/implicit-refs/top.scm Executable file
View File

@ -0,0 +1,62 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

115
collects/tests/eopl/chapter4/mutable-pairs/data-structures.scm Executable file
View File

@ -0,0 +1,115 @@
(module data-structures (lib "eopl.ss" "eopl")
(require "lang.scm") ; for expression?
(require "store.scm") ; for reference?
(require "pairvals.scm")
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean, a procval, or a
;;; reference.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?))
(ref-val
(ref reference?))
(mutpair-val
(p mutpair?))
)
;;; extractors:
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval->ref
(lambda (v)
(cases expval v
(ref-val (ref) ref)
(else (expval-extractor-error 'reference v)))))
(define expval->mutpair
(lambda (v)
(cases expval v
(mutpair-val (ref) ref)
(else (expval-extractor-error 'mutable-pair v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
;;;;;;;;;;;;;;;; environment data structures ;;;;;;;;;;;;;;;;
(define-datatype environment environment?
(empty-env)
(extend-env
(bvar symbol?)
(bval reference?) ; new for implicit-refs
(saved-env environment?))
(extend-env-rec*
(proc-names (list-of symbol?))
(b-vars (list-of symbol?))
(proc-bodies (list-of expression?))
(saved-env environment?)))
;; env->list : Env -> List
;; used for pretty-printing and debugging
(define env->list
(lambda (env)
(cases environment env
(empty-env () '())
(extend-env (sym val saved-env)
(cons
(list sym val) ; val is a denoted value-- a
; reference.
(env->list saved-env)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cons
(list 'letrec p-names '...)
(env->list saved-env))))))
;; expval->printable : ExpVal -> List
;; returns a value like its argument, except procedures get cleaned
;; up with env->list
(define expval->printable
(lambda (val)
(cases expval val
(proc-val (p)
(cases proc p
(procedure (var body saved-env)
(list 'procedure var '... (env->list saved-env)))))
(else val))))
)

129
collects/tests/eopl/chapter4/mutable-pairs/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

60
collects/tests/eopl/chapter4/mutable-pairs/environments.scm Executable file
View File

@ -0,0 +1,60 @@
(module environments (lib "eopl.ss" "eopl")
(require "data-structures.scm")
(require "store.scm")
(provide init-env empty-env extend-env apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> environment
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
(define init-env
(lambda ()
(extend-env
'i (newref (num-val 1))
(extend-env
'v (newref (num-val 5))
(extend-env
'x (newref (num-val 10))
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
(define apply-env
(lambda (env search-sym)
(cases environment env
(empty-env ()
(eopl:error 'apply-env "No binding for ~s" search-sym))
(extend-env (bvar bval saved-env)
(if (eqv? search-sym bvar)
bval
(apply-env saved-env search-sym)))
(extend-env-rec* (p-names b-vars p-bodies saved-env)
(cond
((location search-sym p-names)
=> (lambda (n)
(newref
(proc-val
(procedure
(list-ref b-vars n)
(list-ref p-bodies n)
env)))))
(else (apply-env saved-env search-sym)))))))
(define location
(lambda (sym syms)
(cond
((null? syms) #f)
((eqv? sym (car syms)) 0)
((location sym (cdr syms))
=> (lambda (n)
(+ n 1)))
(else #f))))
)

187
collects/tests/eopl/chapter4/mutable-pairs/interp.scm Executable file
View File

@ -0,0 +1,187 @@
(module interp (lib "eopl.ss" "eopl")
;; interpreter for the MUTABLE-PAIRS language
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(require "store.scm")
(require "pairvals.scm")
(provide value-of-program value-of instrument-let instrument-newref)
;;;;;;;;;;;;;;;; switches for instrument-let ;;;;;;;;;;;;;;;;
(define instrument-let (make-parameter #f))
;; say (instrument-let #t) to turn instrumentation on.
;; (instrument-let #f) to turn it off again.
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(initialize-store!)
(cases program pgm
(a-program (body)
(value-of body (init-env))))))
;; value-of : Exp * Env -> ExpVal
;; Page: 126
(define value-of
(lambda (exp env)
(cases expression exp
(const-exp (num) (num-val num))
(var-exp (var) (deref (apply-env env var)))
(diff-exp (exp1 exp2)
(let ((val1
(expval->num
(value-of exp1 env)))
(val2
(expval->num
(value-of exp2 env))))
(num-val
(- val1 val2))))
(zero?-exp (exp1)
(let ((val1 (expval->num (value-of exp1 env))))
(if (zero? val1)
(bool-val #t)
(bool-val #f))))
(if-exp (exp0 exp1 exp2)
(if (expval->bool (value-of exp0 env))
(value-of exp1 env)
(value-of exp2 env)))
;;; Uninstrumented version
;;; (let-exp (id rhs body)
;;; (let ((val (value-of rhs env)))
;;; (value-of body
;;; (extend-env id (newref val) env))))
(let-exp (var exp1 body)
(if (instrument-let)
(eopl:printf "entering let ~s~%" var))
(let ((val (value-of exp1 env)))
(let ((new-env (extend-env var (newref val) env)))
(if (instrument-let)
(begin
(eopl:printf "entering body of let ~s with env =~%" var)
(pretty-print (env->list new-env))
(eopl:printf "store =~%")
(pretty-print (store->readable (get-store-as-list)))
(eopl:printf "~%")
))
(value-of body new-env))))
(proc-exp (var body)
(proc-val
(procedure var body env)))
(call-exp (rator rand)
(let ((proc (expval->proc (value-of rator env)))
(arg (value-of rand env)))
(apply-procedure proc arg)))
(letrec-exp (p-names b-vars p-bodies letrec-body)
(value-of letrec-body
(extend-env-rec* p-names b-vars p-bodies env)))
(begin-exp (exp1 exps)
(letrec
((value-of-begins
(lambda (e1 es)
(let ((v1 (value-of e1 env)))
(if (null? es)
v1
(value-of-begins (car es) (cdr es)))))))
(value-of-begins exp1 exps)))
(assign-exp (x e)
(begin
(setref!
(apply-env env x)
(value-of e env))
(num-val 27)))
(newpair-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(mutpair-val (make-pair v1 v2))))
(left-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((p1 (expval->mutpair v1)))
(left p1))))
(right-exp (exp1)
(let ((v1 (value-of exp1 env)))
(let ((p1 (expval->mutpair v1)))
(right p1))))
(setleft-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(let ((p (expval->mutpair v1)))
(begin
(setleft p v2)
(num-val 82)))))
(setright-exp (exp1 exp2)
(let ((v1 (value-of exp1 env))
(v2 (value-of exp2 env)))
(let ((p (expval->mutpair v1)))
(begin
(setright p v2)
(num-val 83)))))
)))
;; apply-procedure : Proc * ExpVal -> ExpVal
;; (define apply-procedure
;; (lambda (proc1 arg)
;; (cases proc proc1
;; (procedure (bvar body saved-env)
;; (value-of body
;; (extend-env bvar (newref arg) saved-env))))))
(define apply-procedure
(lambda (proc1 arg)
(cases proc proc1
(procedure (var body saved-env)
(let ((r (newref arg)))
(let ((new-env (extend-env var r saved-env)))
(if (instrument-let)
(begin
(eopl:printf
"entering body of proc ~s with env =~%"
var)
(pretty-print (env->list new-env))
(eopl:printf "store =~%")
(pretty-print (store->readable (get-store-as-list)))
(eopl:printf "~%")))
(value-of body new-env)))))))
;; store->readable : Listof(List(Ref,Expval))
;; -> Listof(List(Ref,Something-Readable))
(define store->readable
(lambda (l)
(map
(lambda (p)
(list
(car p)
(expval->printable (cadr p))))
l)))
)

102
collects/tests/eopl/chapter4/mutable-pairs/lang.scm Executable file
View File

@ -0,0 +1,102 @@
(module lang (lib "eopl.ss" "eopl")
;; language for MUTABLE-PAIRS
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("zero?" "(" expression ")")
zero?-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("letrec"
(arbno identifier "(" identifier ")" "=" expression)
"in" expression)
letrec-exp)
(expression
("begin" expression (arbno ";" expression) "end")
begin-exp)
(expression
("set" identifier "=" expression)
assign-exp)
;; new for mutable-pairs
(expression
("newpair" "(" expression "," expression ")")
newpair-exp)
(expression
("left" "(" expression ")")
left-exp)
(expression
("setleft" expression "=" expression)
setleft-exp)
(expression
("right" "(" expression ")")
right-exp)
(expression
("setright" expression "=" expression)
setright-exp)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

58
collects/tests/eopl/chapter4/mutable-pairs/pairval1.scm Executable file
View File

@ -0,0 +1,58 @@
(module pairval1 (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "store.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;;
;; represent a mutable pair as two references.
;; Page: 124
(define-datatype mutpair mutpair?
(a-pair
(left-loc reference?)
(right-loc reference?)))
;; make-pair : ExpVal * ExpVal -> MutPair
;; Page: 124
(define make-pair
(lambda (val1 val2)
(a-pair
(newref val1)
(newref val2))))
;; left : MutPair -> ExpVal
;; Page: 125
(define left
(lambda (p)
(cases mutpair p
(a-pair (left-loc right-loc)
(deref left-loc)))))
;; right : MutPair -> ExpVal
;; Page: 125
(define right
(lambda (p)
(cases mutpair p
(a-pair (left-loc right-loc)
(deref right-loc)))))
;; setleft : MutPair * ExpVal -> Unspecified
;; Page: 125
(define setleft
(lambda (p val)
(cases mutpair p
(a-pair (left-loc right-loc)
(setref! left-loc val)))))
;; setright : MutPair * ExpVal -> Unspecified
;; Page: 125
(define setright
(lambda (p val)
(cases mutpair p
(a-pair (left-loc right-loc)
(setref! right-loc val)))))
)

81
collects/tests/eopl/chapter4/mutable-pairs/pairval2.scm Executable file
View File

@ -0,0 +1,81 @@
(module pairval2 (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "store.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;;
;; model a mutable pair as two consecutive locations (left and
;; right), and represent it as a reference to the first.
;; mutpair? : SchemeVal -> Bool
;; Page: 129
;;
;; Not every reference is really a mutpair, but this test is good
;; enough, because in the implicit-refs language, you
;; can't get your hands on a reference otherwise.
(define mutpair?
(lambda (v)
(reference? v)))
;; make-pair : ExpVal * ExpVal -> MutPair
;; Page: 129
(define make-pair
(lambda (val1 val2)
(let ((ref1 (newref val1)))
(let ((ref2 (newref val2)))
ref1))))
;; left : MutPair -> ExpVal
;; Page: 129
(define left
(lambda (p)
(deref p)))
;; right : MutPair -> ExpVal
;; Page: 129
(define right
(lambda (p)
(deref (+ 1 p))))
;; setleft : MutPair * ExpVal -> Unspecified
;; Page: 129
(define setleft
(lambda (p val)
(setref! p val)))
;; setright : MutPair * Expval -> Unspecified
;; Page: 129
(define setright
(lambda (p val)
(setref! (+ 1 p) val)))
)
;; (define mutpair? reference?) ; inaccurate
;; (define make-pair
;; (lambda (val1 val2)
;; (let ((ref1 (newref val1)))
;; (let ((ref2 (newref val2))) ; guaranteed to be ref1 + 1
;; ref1))))
;; (define left
;; (lambda (p)
;; (deref p)))
;; (define right
;; (lambda (p)
;; (deref (+ 1 p))))
;; (define setleft
;; (lambda (p val)
;; (setref! p val)))
;; (define setright
;; (lambda (p val)
;; (setref! (+ 1 p) val)))

12
collects/tests/eopl/chapter4/mutable-pairs/pairvals.scm Executable file
View File

@ -0,0 +1,12 @@
(module pairvals (lib "eopl.ss" "eopl")
;; choose one of the following:
;; (require "pairval1.scm")
;; (provide (all-from "pairval1.scm"))
;; or
(require "pairval2.scm")
(provide (all-from "pairval2.scm"))
)

112
collects/tests/eopl/chapter4/mutable-pairs/store.scm Executable file
View File

@ -0,0 +1,112 @@
(module store (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(provide initialize-store! reference? newref deref setref!
instrument-newref get-store-as-list)
(define instrument-newref (make-parameter #f))
;;;;;;;;;;;;;;;; references and the store ;;;;;;;;;;;;;;;;
;;; world's dumbest model of the store: the store is a list and a
;;; reference is number which denotes a position in the list.
;; the-store: a Scheme variable containing the current state of the
;; store. Initially set to a dummy variable.
(define the-store 'uninitialized)
;; empty-store : () -> Sto
;; Page: 111
(define empty-store
(lambda () '()))
;; initialize-store! : () -> Sto
;; usage: (initialize-store!) sets the-store to the empty-store
;; Page 111
(define initialize-store!
(lambda ()
(set! the-store (empty-store))))
;; get-store : () -> Sto
;; Page: 111
;; This is obsolete. Replaced by get-store-as-list below
(define get-store
(lambda () the-store))
;; reference? : SchemeVal -> Bool
;; Page: 111
(define reference?
(lambda (v)
(integer? v)))
;; newref : ExpVal -> Ref
;; Page: 111
(define newref
(lambda (val)
(let ((next-ref (length the-store)))
(set! the-store
(append the-store (list val)))
(if (instrument-newref)
(eopl:printf
"newref: allocating location ~s with initial contents ~s~%"
next-ref val))
next-ref)))
;; deref : Ref -> ExpVal
;; Page 111
(define deref
(lambda (ref)
(list-ref the-store ref)))
;; setref! : Ref * ExpVal -> Unspecified
;; Page: 112
(define setref!
(lambda (ref val)
(set! the-store
(letrec
((setref-inner
;; returns a list like store1, except that position ref1
;; contains val.
(lambda (store1 ref1)
(cond
((null? store1)
(report-invalid-reference ref the-store))
((zero? ref1)
(cons val (cdr store1)))
(else
(cons
(car store1)
(setref-inner
(cdr store1) (- ref1 1))))))))
(setref-inner the-store ref)))))
(define report-invalid-reference
(lambda (ref the-store)
(eopl:error 'setref
"illegal reference ~s in store ~s"
ref the-store)))
;; get-store-as-list : () -> Listof(List(Ref,Expval))
;; Exports the current state of the store as a scheme list.
;; (get-store-as-list '(foo bar baz)) = ((0 foo)(1 bar) (2 baz))
;; where foo, bar, and baz are expvals.
;; If the store were represented in a different way, this would be
;; replaced by something cleverer.
;; Replaces get-store (p. 111)
(define get-store-as-list
(lambda ()
(letrec
((inner-loop
;; convert sto to list as if its car was location n
(lambda (sto n)
(if (null? sto)
'()
(cons
(list n (car sto))
(inner-loop (cdr sto) (+ n 1)))))))
(inner-loop the-store 0))))
)

179
collects/tests/eopl/chapter4/mutable-pairs/tests.scm Executable file
View File

@ -0,0 +1,179 @@
(module tests mzscheme
(provide test-list)
;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;;
(define test-list
'(
;; 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) -(x,1) 30)" 29)
(apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29)
(let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29)
(nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1)
(nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)"
-1)
(y-combinator-1 "
let fix = proc (f)
let d = proc (x) proc (z) ((f (x x)) z)
in proc (n) ((f (d d)) n)
in let
t4m = proc (f) proc(x) 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 f(x) = -(x,1) in (f 33)" 32)
(simple-letrec-2
"letrec f(x) = if zero?(x) then 0 else -((f -(x,1)), -2) in (f 4)"
8)
(simple-letrec-3
"let m = -5
in letrec f(x) = 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 even(odd) = proc(x) if zero?(x) then 1 else (odd -(x,1))
in letrec odd(x) = if zero?(x) then 0 else ((even odd) -(x,1))
in (odd 13)" 1)
(begin-test-1
"begin 1; 2; 3 end"
3)
;; extremely primitive testing for mutable variables
(assignment-test-1 "let x = 17
in begin set x = 27; x end"
27)
(gensym-test
"let g = let count = 0 in proc(d)
let d = set count = -(count,-1)
in count
in -((g 11), (g 22))"
-1)
(even-odd-via-set "
let x = 0
in letrec even(d) = if zero?(x) then 1
else let d = set x = -(x,1)
in (odd d)
odd(d) = if zero?(x) then 0
else let d = set x = -(x,1)
in (even d)
in let d = set x = 13 in (odd -99)" 1)
;; even more primitive testing for mutable pairs
(simple-mutpair-left-1 "let p = newpair(22,33) in left(p)" 22)
(simple-mutpair-right-1 "let p = newpair(22,33) in right(p)" 33)
(simple-mutpair-setleft-1 "
let p = newpair(22,33) in begin setleft p = 77; left(p) end" 77)
(simple-mutpair-setleft-2 "
let p = newpair(22,33) in begin setleft p = 77; right(p) end" 33)
(simple-mutpair-setright-1 "
let p = newpair(22,33) in begin setright p = 77; right(p) end" 77)
(simple-mutpair-setright-2 "
let p = newpair(22,33) in begin setright p = 77; left(p) end" 22)
(gensym-using-mutable-pair-left
"let g = let count = newpair(0,0)
in proc (dummy)
begin
setleft count = -(left(count), -1);
left(count)
end
in -((g 22), (g 22))"
-1)
(gensym-using-mutable-pair-right
"let g = let count = newpair(0,0)
in proc (dummy)
begin
setright count = -(right(count), -1);
right(count)
end
in -((g 22), (g 22))"
-1)
(example-for-mutable-pairs-section "
let glo = newpair(11,22)
in let f = proc (loc)
begin % this is a comment
setright loc = left(loc);
setleft glo = 99;
-(left(loc),right(loc))
end
in (f glo)"
88)
))
)

64
collects/tests/eopl/chapter4/mutable-pairs/top.scm Executable file
View File

@ -0,0 +1,64 @@
(module top (lib "eopl.ss" "eopl")
;; top level module. Loads all required pieces.
;; Run the test suite with (run-all).
(require "drscheme-init.scm")
(require "data-structures.scm") ; for expval constructors
(require "lang.scm") ; for scan&parse
(require "interp.scm") ; for value-of-program
(require "tests.scm") ; for test-list
(provide run run-all)
;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;;
;; run : String -> ExpVal
(define run
(lambda (string)
(value-of-program (scan&parse string))))
;; run-all : () -> Unspecified
;; runs all the tests in test-list, comparing the results with
;; equal-answer?
(define run-all
(lambda ()
(run-tests! run equal-answer? test-list)))
(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)))))
;; run-one : Sym -> ExpVal
;; (run-one sym) runs the test whose name is sym
(define run-one
(lambda (test-name)
(let ((the-test (assoc test-name test-list)))
(cond
((assoc test-name test-list)
=> (lambda (test)
(run (cadr test))))
(else (eopl:error 'run-one "no such test: ~s" test-name))))))
;; (run-all)
)

9100
collects/tests/eopl/chapter5/exceptions/big-trace3.scm Executable file
View File

File diff suppressed because it is too large Load Diff

85
collects/tests/eopl/chapter5/exceptions/data-structures.scm Executable file
View File

@ -0,0 +1,85 @@
(module data-structures (lib "eopl.ss" "eopl")
(require "lang.scm") ; for expression?
(provide (all-defined)) ; too many things to list
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
;;; an expressed value is either a number, a boolean, a procval, or a
;;; list of expvals.
(define-datatype expval expval?
(num-val
(value number?))
(bool-val
(boolean boolean?))
(proc-val
(proc proc?))
(list-val
(lst (list-of expval?))))
;;; extractors:
(define expval->num
(lambda (v)
(cases expval v
(num-val (num) num)
(else (expval-extractor-error 'num v)))))
(define expval->bool
(lambda (v)
(cases expval v
(bool-val (bool) bool)
(else (expval-extractor-error 'bool v)))))
(define expval->proc
(lambda (v)
(cases expval v
(proc-val (proc) proc)
(else (expval-extractor-error 'proc v)))))
(define expval->list
(lambda (v)
(cases expval v
(list-val (lst) lst)
(else (expval-extractor-error 'list v)))))
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
variant value)))
;; ;;;;;;;;;;;;;;;; continuations ;;;;;;;;;;;;;;;;
;; moved to interp.scm
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
(define-datatype proc proc?
(procedure
(bvar symbol?)
(body expression?)
(env environment?)))
;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;;
;;; replaced by custom environment structure in environments.scm.
;;; This represents an environment as an alist ((id rhs) ...)
;;; where rhs is either an expval or a list (bvar body)
;;; expval is for extend-env; the list is for extend-env-rec.
;;; this representation is designed to make the printed representation
;;; of the environment more readable.
;;; The code for this is in environments.scm, but we need environment?
;;; for define-datatype proc, so we write an appoximation:
(define environment?
(list-of
(lambda (p)
(and
(pair? p)
(symbol? (car p))))))
)

129
collects/tests/eopl/chapter5/exceptions/drscheme-init.scm Executable file
View File

@ -0,0 +1,129 @@
;; drscheme-init.scm - compatibility file for DrScheme
;; usage: (require "drscheme-init.scm")
;;; makes structs printable, and provides basic functionality for
;;; testing. This includes pretty-printing and tracing.
(module drscheme-init mzscheme
;; show the contents of define-datatype values
(print-struct #t)
(require (lib "pretty.ss"))
(provide (all-from (lib "pretty.ss")))
(require (lib "trace.ss"))
(provide (all-from (lib "trace.ss")))
(provide make-parameter)
(provide
run-experiment
run-tests!
stop-after-first-error
run-quietly
)
;; safely apply procedure fn to a list of args.
;; if successful, return (cons #t val)
;; if eopl:error is invoked, returns (cons #f string), where string is the
;; format string generated by eopl:error. If somebody manages to raise a
;; value other than an exception, then the raised value is reported.
(define apply-safely
(lambda (proc args)
(with-handlers ([(lambda (exn) #t) ; catch any error
(lambda (exn) ; evaluate to a failed test result
(cons #f
(if (exn? exn)
(exn-message exn)
exn)))])
(let ([actual (apply proc args)])
(cons #t actual)))))
;; run-experiment :
;; ((a ...) -> b) * (a ...) * b * (b * b -> bool)
;; -> (cons bool b)
;; usage: (run-experiment fn args correct-answer equal-answer?)
;; Applies fn to args. Compares the result to correct-answer.
;; Returns (cons bool b) where bool indicates whether the
;; answer is correct.
(define run-experiment
(lambda (fn args correct-answer equal-answer?)
(let*
((result (apply-safely fn args))
;; ans is either the answer or the args to eopl:error
(error-thrown? (not (car result)))
(ans (cdr result)))
(cons
(if (eqv? correct-answer 'error)
error-thrown?
(equal-answer? ans correct-answer))
ans))))
(define stop-after-first-error (make-parameter #f))
(define run-quietly (make-parameter #t))
;; run-tests! : (arg -> outcome) * (any * any -> bool) * (list-of test)
;; -> unspecified
;; where:
;; test ::= (name arg outcome)
;; outcome ::= ERROR | any
;; usage: (run-tests! run-fn equal-answer? tests)
;; for each item in tests, apply run-fn to the arg. Check to see if
;; the outcome is right, comparing values using equal-answer?.
;; print a log of the tests.
;; at the end, print either "no bugs found" or the list of tests
;; failed.
;; Normally, run-tests! will recover from any error and continue to
;; the end of the test suite. This behavior can be altered by
;; setting (stop-after-first-error #t).
(define (run-tests! run-fn equal-answer? tests)
(let ((tests-failed '()))
(for-each
(lambda (test-item)
(let ((name (car test-item))
(pgm (cadr test-item))
(correct-answer (caddr test-item)))
(printf "test: ~a~%" name)
(let* ((result
(run-experiment
run-fn (list pgm) correct-answer equal-answer?))
(correct? (car result))
(actual-answer (cdr result)))
(if (or
(not correct?)
(not (run-quietly)))
(begin
(printf "~a~%" pgm)
(printf "correct outcome: ~a~%" correct-answer)
(printf "actual outcome: ")
(pretty-display actual-answer)))
(if correct?
(printf "correct~%~%")
(begin
(printf "incorrect~%~%")
;; stop on first error if stop-after-first? is set:
(if (stop-after-first-error)
(error name "incorrect outcome detected"))
(set! tests-failed
(cons name tests-failed)))))))
tests)
(if (null? tests-failed)
(printf "no bugs found~%")
(printf "incorrect answers on tests: ~a~%"
(reverse tests-failed)))))
)

70
collects/tests/eopl/chapter5/exceptions/environments.scm Executable file
View File

@ -0,0 +1,70 @@
(module environments (lib "eopl.ss" "eopl")
(require "data-structures.scm")
(provide init-env empty-env extend-env extend-env-rec apply-env)
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
;; init-env : () -> environment
;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.
(define init-env
(lambda ()
(extend-env
'i (num-val 1)
(extend-env
'v (num-val 5)
(extend-env
'x (num-val 10)
(empty-env))))))
;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;;
;;; represent environment as an alist ((id rhs) ...)
;;; rhs is either an expval or a list (bvar body)
;;; expval is for extend-env; the list is for extend-env-rec.
;;; this representation is designed to make the printed representation
;;; of the environment more readable.
(define empty-env
(lambda ()
'()))
(define empty-env?
(lambda (x) (null? x)))
(define extend-env
(lambda (sym val old-env)
(cons (list sym val) old-env)))
(define extend-env-rec
(lambda (p-name b-var p-body saved-env)
(cons
(list p-name b-var p-body)
saved-env)))
(define apply-env
(lambda (env search-sym)
(if (null? env)
(eopl:error 'apply-env "No binding for ~s" search-sym)
(let* ((binding (car env))
(id (list-ref binding 0))
(expval-or-bvar (list-ref binding 1)))
(cond
((not (eqv? search-sym id))
(apply-env (cdr env) search-sym))
((not (symbol? expval-or-bvar))
;; this was built by extend-env
expval-or-bvar)
(else
;; this was built by extend-env-rec
(let ((bvar (cadr binding))
(body (caddr binding)))
(proc-val (procedure bvar body env)))))))))
)

210
collects/tests/eopl/chapter5/exceptions/interp.scm Executable file
View File

@ -0,0 +1,210 @@
(module interp (lib "eopl.ss" "eopl")
(require "drscheme-init.scm")
(require "lang.scm")
(require "data-structures.scm")
(require "environments.scm")
(provide value-of-program value-of/k)
(provide trace-apply-procedure)
(define trace-apply-procedure (make-parameter #f))
;;;;;;;;;;;;;;;; continuations ;;;;;;;;;;;;;;;;
(define-datatype continuation continuation?
(end-cont) ; []
(diff1-cont ; cont[(- [] (value-of e2 env))]
(exp2 expression?)
(env environment?)
(cont continuation?))
(diff2-cont ; cont[(- val1 [])]
(val1 expval?)
(cont continuation?))
(unop-arg-cont
(unop unary-op?)
(cont continuation?))
(if-test-cont
(exp2 expression?)
(exp3 expression?)
(env environment?)
(cont continuation?))
(rator-cont ; cont[(apply-proc [] (value-of rand env))]
(rand expression?)
(env environment?)
(cont continuation?))
(rand-cont ; cont[(apply-proc val1 [])]
(val1 expval?)
(cont continuation?))
(try-cont
(var symbol?)
(handler-exp expression?)
(env environment?)
(cont continuation?))
(raise1-cont
(saved-cont continuation?))
)
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;; value-of-program : Program -> ExpVal
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (body)
(value-of/k body (init-env) (end-cont))))))
;; value-of/k : Exp * Env * Cont -> FinalAnswer
;; Page: 173
(define value-of/k
(lambda (exp env cont)
(cases expression exp
(const-exp (num) (apply-cont cont (num-val num)))
(const-list-exp (nums)
(apply-cont cont
(list-val (map num-val nums))))
(var-exp (var) (apply-cont cont (apply-env env var)))
(diff-exp (exp1 exp2)
(value-of/k exp1 env
(diff1-cont exp2 env cont)))
(unop-exp (unop exp1)
(value-of/k exp1 env
(unop-arg-cont unop cont)))
(if-exp (exp1 exp2 exp3)
(value-of/k exp1 env
(if-test-cont exp2 exp3 env cont)))
(proc-exp (var body)
(apply-cont cont
(proc-val
(procedure var body env))))
(call-exp (rator rand)
(value-of/k rator env
(rator-cont rand env cont)))
;; make let a macro, because I'm too lazy to add the extra
;; continuation
(let-exp (var exp1 body)
(value-of/k
(call-exp (proc-exp var body) exp1)
env
cont))
(letrec-exp (p-name b-var p-body letrec-body)
(value-of/k
letrec-body
(extend-env-rec p-name b-var p-body env)
cont))
(try-exp (exp1 var handler-exp)
(value-of/k exp1 env
(try-cont var handler-exp env cont)))
(raise-exp (exp1)
(value-of/k exp1 env
(raise1-cont cont))))))
;; apply-cont : continuation * expval -> final-expval
(define apply-cont
(lambda (cont val)
(cases continuation cont
(end-cont () val)
(diff1-cont (exp2 saved-env saved-cont)
(value-of/k exp2 saved-env (diff2-cont val saved-cont)))
(diff2-cont (val1 saved-cont)
(let ((n1 (expval->num val1))
(n2 (expval->num val)))
(apply-cont saved-cont
(num-val (- n1 n2)))))
(unop-arg-cont (unop cont)
(apply-cont cont
(apply-unop unop val)))
(if-test-cont (exp2 exp3 env cont)
(if (expval->bool val)
(value-of/k exp2 env cont)
(value-of/k exp3 env cont)))
(rator-cont (rand saved-env saved-cont)
(value-of/k rand saved-env
(rand-cont val saved-cont)))
(rand-cont (val1 saved-cont)
(let ((proc (expval->proc val1)))
(apply-procedure proc val saved-cont)))
;; the body of the try finished normally-- don't evaluate the handler
(try-cont (var handler-exp saved-env saved-cont)
(apply-cont saved-cont val))
;; val is the value of the argument to raise
(raise1-cont (saved-cont)
;; we put the short argument first to make the trace more readable.
(apply-handler val saved-cont))
)))
;; apply-handler : ExpVal * Cont -> FinalAnswer
(define apply-handler
(lambda (val cont)
(cases continuation cont
;; interesting cases
(try-cont (var handler-exp saved-env saved-cont)
(value-of/k handler-exp
(extend-env var val saved-env)
saved-cont))
(end-cont () (eopl:error 'apply-handler "uncaught exception!"))
;; otherwise, just look for the handler...
(diff1-cont (exp2 saved-env saved-cont)
(apply-handler val saved-cont))
(diff2-cont (val1 saved-cont)
(apply-handler val saved-cont))
(if-test-cont (exp2 exp3 env saved-cont)
(apply-handler val saved-cont))
(unop-arg-cont (unop saved-cont)
(apply-handler val saved-cont))
(rator-cont (rand saved-env saved-cont)
(apply-handler val saved-cont))
(rand-cont (val1 saved-cont)
(apply-handler val saved-cont))
(raise1-cont (cont)
(apply-handler val cont))
)))
;; apply-procedure : procedure * expval * cont -> final-expval
(define apply-procedure
(lambda (proc1 arg cont)
(cases proc proc1
(procedure (var body saved-env)
(value-of/k body
(extend-env var arg saved-env)
cont)))))
(define apply-unop
(lambda (unop val)
(cases unary-op unop
(null?-unop ()
(bool-val
(null? (expval->list val))))
(car-unop ()
(car (expval->list val)))
(cdr-unop ()
(list-val (cdr (expval->list val))))
(zero?-unop ()
(bool-val
(zero? (expval->num val)))))))
;; to get the detailed trace:
;; (trace value-of/k apply-cont apply-handler)
)

96
collects/tests/eopl/chapter5/exceptions/lang.scm Executable file
View File

@ -0,0 +1,96 @@
(module lang (lib "eopl.ss" "eopl")
;; grammar for the EXCEPTIONS language. This is a somewhat cut-down
;; version of the LETREC language.
;; exercise: allow the "list" operator to take expressions instead
;; of just numbers.
(require "drscheme-init.scm")
(provide (all-defined))
;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;
(define the-lexical-spec
'((whitespace (whitespace) skip)
(comment ("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "_" "-" "?")))
symbol)
(number (digit (arbno digit)) number)
(number ("-" digit (arbno digit)) number)
))
(define the-grammar
'((program (expression) a-program)
(expression (number) const-exp)
(expression
("-" "(" expression "," expression ")")
diff-exp)
(expression
("if" expression "then" expression "else" expression)
if-exp)
(expression (identifier) var-exp)
(expression
("proc" "(" identifier ")" expression)
proc-exp)
(expression
("(" expression expression ")")
call-exp)
(expression
("let" identifier "=" expression "in" expression)
let-exp)
(expression
("letrec"
identifier "(" identifier ")" "=" expression
"in" expression)
letrec-exp)
;; Lists. We will have lists of literal numbers only.
(expression
("list" "(" (separated-list number ",") ")")
const-list-exp)
(expression
(unary-op "(" expression ")")
unop-exp)
(expression
("try" expression "catch" "(" identifier ")" expression)
try-exp)
(expression
("raise" expression)
raise-exp)
(unary-op ("null?") null?-unop)
(unary-op ("car") car-unop)
(unary-op ("cdr" ) cdr-unop)
(unary-op ("zero?") zero?-unop)
))
;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define show-the-datatypes
(lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))
(define scan&parse
(sllgen:make-string-parser the-lexical-spec the-grammar))
(define just-scan
(sllgen:make-string-scanner the-lexical-spec the-grammar))
)

Some files were not shown because too many files have changed in this diff Show More