├── ch7 ├── 03.scm ├── 02.scm ├── 04.scm ├── 19.scm ├── 14.scm ├── 13.scm ├── 01.scm ├── 15.scm └── base │ ├── equal-type.scm │ └── data-structures.scm ├── ch3 ├── 04.scm ├── 05.scm ├── 03.scm ├── 01.scm ├── 30.scm ├── 24.scm ├── 25.scm └── base │ └── environments.scm ├── .gitignore ├── ch4 ├── 08.scm ├── 28.txt ├── 01.scm ├── base │ ├── pair-v2.scm │ └── pair-v1.scm └── 09.scm ├── ch2 ├── 17.scm ├── 08.scm ├── 23.scm ├── 06.scm ├── 04.scm ├── 24.scm ├── 27.scm ├── 05.scm ├── 12.scm ├── 09.scm ├── 31.scm ├── 28.scm ├── 22.scm ├── 13.scm ├── 29.scm ├── 18.scm ├── 10.scm ├── 19.scm ├── 30.scm ├── 21.scm ├── 01.scm ├── 11.scm ├── 14.scm ├── 07.scm ├── 16.scm └── 15.scm ├── ch6 ├── 09.scm ├── 14.scm ├── 28.scm ├── 19.scm ├── 24.scm ├── 12.scm ├── 10.scm ├── 05.scm ├── 27.scm ├── 22.scm ├── 02.scm ├── 29.scm ├── 21.scm ├── 01.scm ├── 03.scm ├── 20.scm ├── 06.scm ├── base │ ├── let-lang.scm │ ├── cps-in-lang.scm │ └── exception-lang.scm └── 30.scm ├── base ├── chapter2 │ ├── README.txt │ ├── utils.scm │ ├── sec2.2-proc-rep.scm │ └── sec2.2-ds-rep.scm ├── chapter3 │ ├── let-lang │ │ ├── compiled │ │ │ └── drracket │ │ │ │ └── errortrace │ │ │ │ ├── drscheme-init_scm.zo │ │ │ │ └── drscheme-init_scm.dep │ │ ├── environments.scm │ │ ├── lang.scm │ │ ├── top.scm │ │ ├── data-structures.scm │ │ ├── tests.scm │ │ └── interp.scm │ ├── lexaddr-lang │ │ ├── environments.scm │ │ ├── top.scm │ │ └── lang.scm │ ├── letrec-lang │ │ ├── environments.scm │ │ ├── data-structures.scm │ │ ├── top.scm │ │ └── lang.scm │ └── proc-lang │ │ ├── ds-rep │ │ ├── environments.scm │ │ ├── lang.scm │ │ └── top.scm │ │ └── proc-rep │ │ ├── environments.scm │ │ ├── lang.scm │ │ └── top.scm ├── chapter5 │ ├── letrec-lang │ │ ├── eopl-without-exp.scm │ │ ├── top.scm │ │ ├── environments.scm │ │ ├── top-interp-registers.scm │ │ ├── top-interp.scm │ │ └── lang.scm │ ├── test-all.scm │ ├── thread-lang │ │ ├── queues.scm │ │ ├── top.scm │ │ └── semaphores.scm │ └── exceptions │ │ └── top.scm ├── chapter4 │ ├── call-by-need │ │ ├── pairvals.scm │ │ ├── pairval1.scm │ │ ├── top.scm │ │ └── pairval2.scm │ ├── mutable-pairs │ │ ├── pairvals.scm │ │ ├── pairval1.scm │ │ ├── top.scm │ │ └── environments.scm │ ├── call-by-reference │ │ ├── pairvals.scm │ │ ├── pairval1.scm │ │ └── top.scm │ ├── implicit-refs │ │ └── top.scm │ └── explicit-refs │ │ ├── top.scm │ │ └── environments.scm ├── chapter8 │ ├── simplemodules │ │ ├── expand-type.scm │ │ └── subtyping.scm │ └── full-system │ │ └── scratch.scm ├── chapter7 │ ├── inferred │ │ ├── environments.scm │ │ └── data-structures.scm │ └── checked │ │ ├── environments.scm │ │ └── data-structures.scm └── chapter9 │ ├── typed-oo │ └── static-data-structures.scm │ └── classes │ └── top.scm ├── ch8 ├── 13.scm ├── 08.scm ├── 18.scm ├── 19.scm ├── 22.scm ├── 20.scm ├── 15.scm ├── 21.scm ├── 14.scm ├── base │ ├── renaming.scm │ └── equal-type.scm └── 01.scm ├── ch1 ├── 11.scm ├── 15.scm ├── 24.scm ├── 09.scm ├── 25.scm ├── 17.scm ├── 19.scm ├── 16.scm ├── 31.scm ├── 34.scm ├── 27.scm ├── 23.scm ├── 26.scm ├── 08.scm ├── 32.scm ├── 21.scm ├── 22.scm ├── 12.scm ├── 28.scm ├── 07.scm ├── 13.scm ├── 29.scm ├── 18.scm ├── 20.scm ├── 36.scm ├── 33.scm ├── 30.scm ├── 35-2.scm └── 35.scm ├── libs └── init.scm ├── ch5 └── base │ ├── queues.scm │ ├── semaphores.scm │ ├── semaphores-data-structure.scm │ └── scheduler.scm ├── ch9 ├── 31.scm ├── 12.scm ├── 42.scm ├── oo.scm ├── 03.scm ├── 30.scm ├── 02.scm ├── 07.scm └── base │ ├── typed-oo │ └── static-data-structures.scm │ └── classes │ └── top.scm └── README.md /ch7/03.scm: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /ch3/04.scm: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /ch3/05.scm: -------------------------------------------------------------------------------- 1 | ;; same as 04, :( a bug of this book 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.pyc 3 | *.sublime-workspace 4 | -------------------------------------------------------------------------------- /ch7/02.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; no expression have exactly two types 3 | -------------------------------------------------------------------------------- /ch3/03.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (display (scan&parse "-(55, -(x, 11))")) 4 | -------------------------------------------------------------------------------- /ch4/08.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; setref! will cost linear time, 3 | ;; since it will traverse the list in store 4 | 5 | -------------------------------------------------------------------------------- /ch7/04.scm: -------------------------------------------------------------------------------- 1 | ;; proc(x) x 2 | ;; (t -> t) 3 | 4 | ;; proc(x) proc(y) (x y) 5 | ;; ((t -> t) -> (t -> t)) 6 | -------------------------------------------------------------------------------- /ch2/17.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | ;; may use procedure as expression 5 | ;; similar with 2.14 6 | -------------------------------------------------------------------------------- /ch6/09.scm: -------------------------------------------------------------------------------- 1 | ;; What property of multiplication makes this program optimization possible? 2 | 3 | ;; a * b = b * a 4 | -------------------------------------------------------------------------------- /ch4/28.txt: -------------------------------------------------------------------------------- 1 | 2 | specification of mutable-pair operations 3 | 4 | make-pair 5 | left 6 | right 7 | setleft 8 | setright 9 | -------------------------------------------------------------------------------- /ch3/01.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; (value-of <<3>> p) etc 4 | ;; there are several positions apply this rule 5 | -------------------------------------------------------------------------------- /base/chapter2/README.txt: -------------------------------------------------------------------------------- 1 | (* This directory intentionally left blank *) 2 | 3 | The code snippets in this chapter will be posted at a later time. 4 | -------------------------------------------------------------------------------- /ch8/13.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; Write a module that implements arithmetic using a representation 4 | ;; in which the integer k is represented as 5 ∗ k + 3. 5 | -------------------------------------------------------------------------------- /ch1/11.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; this is mutual recursive 3 | ;; subst-in-s-exp call subst, subst call a smaller substructure on subst-in-s-exp 4 | ;; this is halt 5 | -------------------------------------------------------------------------------- /libs/init.scm: -------------------------------------------------------------------------------- 1 | (load-relative "r5rs.scm") 2 | (load-relative "sllgen.scm") 3 | (load-relative "define-datatype.scm") 4 | ;;(load-relative "grammar.scm") 5 | -------------------------------------------------------------------------------- /ch6/14.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; Complete the interpreter of figure 6.6 by supplying definitions 3 | ;; for value-of-program and apply-cont. 4 | 5 | ;; seems solved in 11.scm 6 | 7 | -------------------------------------------------------------------------------- /ch3/30.scm: -------------------------------------------------------------------------------- 1 | ;; exercise 3.30 2 | ;; (proc-val (procedure b-var p-body env)) 3 | ;; recursive call back save procedure 4 | ;; enviroment now may have var->val or p-name -> procedure 5 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/compiled/drracket/errortrace/drscheme-init_scm.zo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/findmyway/eopl-1/master/base/chapter3/let-lang/compiled/drracket/errortrace/drscheme-init_scm.zo -------------------------------------------------------------------------------- /ch6/28.scm: -------------------------------------------------------------------------------- 1 | ;; Food for thought: imagine a CPS transformer for Scheme programs, 2 | ;; and imagine that you apply it to the first interpreter from chapter 3. 3 | ;; What would the result look like? 4 | -------------------------------------------------------------------------------- /base/chapter5/letrec-lang/eopl-without-exp.scm: -------------------------------------------------------------------------------- 1 | (module eopl-without-exp (lib "eopl.ss" "eopl") 2 | 3 | ;; remove "exp" from the eopl language level, because we use it as 4 | ;; a mutable variable. 5 | 6 | (provide (all-from-except (lib "eopl.ss" "eopl") exp)) 7 | 8 | ) -------------------------------------------------------------------------------- /ch2/08.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | ;; empty-env : () -> Env 5 | (define empty-env 6 | (lambda() '())) 7 | 8 | (define empty-env? 9 | (lambda (env) 10 | (if (null? env) 11 | #t 12 | #f))) 13 | 14 | (equal?? (empty-env? (empty-env)) #t) 15 | -------------------------------------------------------------------------------- /ch5/base/queues.scm: -------------------------------------------------------------------------------- 1 | 2 | (define empty-queue 3 | (lambda () 4 | '())) 5 | 6 | (define empty? null?) 7 | 8 | (define enqueue 9 | (lambda (q val) 10 | (append q (list val)))) 11 | 12 | (define dequeue 13 | (lambda (q f) 14 | (f (car q) (cdr q)))) 15 | -------------------------------------------------------------------------------- /ch6/19.scm: -------------------------------------------------------------------------------- 1 | ;; Writea Scheme procedure tail-form? that takes the syntax tree of a program in CPS-IN, 2 | ;; expressed in the grammar of figure 6.3, and determines whether the same string would 3 | ;; be in tail form according to the grammar of figure 6.5. 4 | 5 | ;; TODO 6 | 7 | -------------------------------------------------------------------------------- /ch9/31.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; yes, it works. 4 | 5 | ;; use a base node class implements tree. 6 | ;; internal node and left node will inherits base class. 7 | ;; base class should have left and right children. 8 | ;; it's more convinent to construct a tree 9 | ;; but cost much space. 10 | -------------------------------------------------------------------------------- /ch1/15.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define duple 4 | (lambda (time val) 5 | (if (= time 0) 6 | '() 7 | (cons val (duple (- time 1) val))))) 8 | 9 | (equal?? (duple 2 3) '(3 3)) 10 | (equal?? (duple 2 '(ha ha)) '((ha ha) (ha ha))) 11 | (equal?? (duple 0 '(haha)) '()) 12 | -------------------------------------------------------------------------------- /ch8/08.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/test.scm") 3 | (load-relative "./base/equal-type.scm") 4 | (load-relative "./base/data-structures.scm") 5 | (load-relative "./base/cases.scm") 6 | (load-relative "./base/simplemodule-lang.scm") 7 | 8 | 9 | (run-all) 10 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/compiled/drracket/errortrace/drscheme-init_scm.dep: -------------------------------------------------------------------------------- 1 | ("5.3.6" ("46910803b066d2fbc463a85d5a726a904d69331e" . "e5114946c64352018c169285a2080e7705814246") (collects #"scheme" #"mzscheme.rkt") (collects #"mzlib" #"trace.rkt") (collects #"mzlib" #"pretty.rkt") (collects #"mzscheme" #"main.rkt")) 2 | -------------------------------------------------------------------------------- /ch1/24.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define every? 4 | (lambda (pred lst) 5 | (if (null? lst) 6 | #t 7 | (if (not (pred (car lst))) 8 | #f 9 | (every? pred (cdr lst)))))) 10 | 11 | (equal?? (every? number? '(a b c 3 e)) #f) 12 | (equal?? (every? number? '(1 2 3 4 5)) #t) 13 | 14 | -------------------------------------------------------------------------------- /ch7/19.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; We wrote: “If ty1 is an unknown type, then the no-occurrence invariant tells us 3 | ;; that it is not bound in the substitution.” Explain in detail why this is so. 4 | 5 | ;; if ty1 is an unknown type and it is bound in the substitution. the substitution left side will also 6 | ;; be an unknown type. 7 | -------------------------------------------------------------------------------- /ch1/09.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define remove 4 | (lambda (s los) 5 | (if (null? los) 6 | '() 7 | (if (eqv? (car los) s) 8 | (remove s (cdr los)) 9 | (cons (car los) (remove s (cdr los))))))) 10 | 11 | (equal?? (remove 'a '(a a b c e a)) '(b c e)) 12 | (equal?? (remove 'a '(a a)) '()) 13 | -------------------------------------------------------------------------------- /ch1/25.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define exists? 4 | (lambda (pred lst) 5 | (if (null? lst) 6 | #f 7 | (if (pred (car lst)) 8 | #t 9 | (exists? pred (cdr lst)))))) 10 | 11 | 12 | (equal?? (exists? number? '(a b c 3 e)) #t) 13 | (equal?? (exists? number? '(a b c d e)) #f) 14 | 15 | 16 | -------------------------------------------------------------------------------- /base/chapter4/call-by-need/pairvals.scm: -------------------------------------------------------------------------------- 1 | (module pairvals (lib "eopl.ss" "eopl") 2 | 3 | ;; choose one of the following: 4 | ;; (require "pairval1.scm") 5 | ;; (provide (all-from "pairval1.scm")) 6 | 7 | ;; or 8 | (require "pairval2.scm") 9 | (provide (all-from "pairval2.scm")) 10 | 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /base/chapter4/mutable-pairs/pairvals.scm: -------------------------------------------------------------------------------- 1 | (module pairvals (lib "eopl.ss" "eopl") 2 | 3 | ;; choose one of the following: 4 | ;; (require "pairval1.scm") 5 | ;; (provide (all-from "pairval1.scm")) 6 | 7 | ;; or 8 | (require "pairval2.scm") 9 | (provide (all-from "pairval2.scm")) 10 | 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /base/chapter5/test-all.scm: -------------------------------------------------------------------------------- 1 | (module test-all scheme 2 | 3 | ;; loads each of the languages in this chapter and tests them. 4 | 5 | ; (require (prefix-in letrec "./letrec-lang/top.scm")) 6 | (require (prefix-in letrec- "letrec-lang/top.scm")) 7 | ; (letrec-stop-after-first-error #t) 8 | (letrec-run-all) 9 | 10 | ) -------------------------------------------------------------------------------- /base/chapter4/call-by-reference/pairvals.scm: -------------------------------------------------------------------------------- 1 | (module pairvals (lib "eopl.ss" "eopl") 2 | 3 | ;; choose one of the following: 4 | ;; (require "pairval1.scm") 5 | ;; (provide (all-from "pairval1.scm")) 6 | 7 | ;; or 8 | (require "pairval2.scm") 9 | (provide (all-from "pairval2.scm")) 10 | 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /ch6/24.scm: -------------------------------------------------------------------------------- 1 | ;; Add list to the lang, as 3.10 2 | 3 | (load-relative "../libs/init.scm") 4 | (load-relative "./base/test.scm") 5 | (load-relative "./base/cps.scm") 6 | (load-relative "./base/data-structures.scm") 7 | (load-relative "./base/cps-cases.scm") 8 | (load-relative "./base/cps-lang.scm") 9 | (load-relative "./base/base-iterp.scm") 10 | 11 | ;; TODO 12 | -------------------------------------------------------------------------------- /ch1/17.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define down 4 | (lambda (list) 5 | (if (null? list) 6 | '() 7 | (cons 8 | (cons (car list) '()) 9 | (down (cdr list)))))) 10 | 11 | 12 | (equal?? (down '(a b)) '((a) (b))) 13 | (equal?? (down '(a)) '((a))) 14 | 15 | (equal?? (down '(a (more (complicated)) object)) 16 | '((a) ((more (complicated))) (object))) 17 | -------------------------------------------------------------------------------- /ch7/14.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; What is wrong with this expression? 3 | ;; letrec 4 | ;; ? even(odd : ?) = 5 | ;; proc (x : ?) 6 | ;; if zero?(x) then 1 else (odd -(x,1)) 7 | ;; in letrec 8 | ;; ? odd(x : bool) = 9 | ;; if zero?(x) then 0 else ((even odd) -(x,1)) 10 | ;; in (odd 13) 11 | 12 | ;; type(x) is bool but used as int in odd(x : bool) 13 | -------------------------------------------------------------------------------- /ch2/23.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define identifier? 4 | (lambda (x) 5 | (if (and (symbol? x) 6 | (eqv? x 'lambda)) 7 | #f 8 | #t))) 9 | 10 | (define-datatype lc-exp lc-exp? 11 | (var-expr 12 | (var identifier?)) 13 | (lambda-expr 14 | (bound-var identifier?) 15 | (body lc-exp?)) 16 | (app-expr 17 | (rator lc-exp?) 18 | (rand lc-exp?))) 19 | -------------------------------------------------------------------------------- /ch1/19.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define list-set 4 | (lambda (lst n x) 5 | (if (null? lst) 6 | '() 7 | (if (eqv? n 0) 8 | (cons x (cdr lst)) 9 | (cons (car lst) (list-set (cdr lst) (- n 1) x)))))) 10 | 11 | (equal?? (list-set '(a b c d) 2 '(1 2)) '(a b (1 2) d)) 12 | (equal?? (list-ref (list-set '(a b c d) 3 '(1 5 10)) 3) '(1 5 10)) 13 | -------------------------------------------------------------------------------- /ch2/06.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; strategy 1, use pair in list 4 | ;; as excersie 2.5 5 | ;; ((d . 6) (y . 8) (x . 7) (y . 14)) 6 | ;; emtpy env is '() 7 | 8 | 9 | ;; strategy 2, use seperate list for key and vals 10 | ;; ((d y x y) (6 8 7 14) 11 | ;; empty env is '( () () ) 12 | 13 | ;; stratege 3, use pairs in list, but based on key 14 | ;; ((d 6) (y 8 14) (x 7)) 15 | ;; empty env is '() 16 | -------------------------------------------------------------------------------- /ch6/12.scm: -------------------------------------------------------------------------------- 1 | ;; Determine whether each of the following expressions is simple. 2 | 3 | ;; -((f -(x, 1)), 1) 4 | ;; --> simple-exp 5 | 6 | ;; (f -(-(x,y), 1)) 7 | ;; --> simple-exp 8 | 9 | ;; if zero?(x) then -(x, y) else -(-(x, y), 1) 10 | ;; --> simple-exp 11 | 12 | ;; let x = proc(y) (y x) in -(x, 3) 13 | ;; --> not simple-exp 14 | 15 | ;; let f = proc(x) x in (f 3) 16 | ;; --> simple-exp 17 | 18 | ;; 19 | -------------------------------------------------------------------------------- /ch1/16.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define invert 4 | (lambda (list) 5 | (if (null? list) 6 | '() 7 | (let ((first (car list))) 8 | (cons 9 | (cons (cadr first) (car first)) 10 | (invert (cdr list))))))) 11 | 12 | 13 | (equal?? (invert '((a 1) (a 2) (b 1) (b 2))) 14 | '((1 . a) (2 . a) (1 . b) (2 . b))) 15 | 16 | (invert '((a 1))) 17 | (equal?? (invert '((a 1))) '((1 . a))) 18 | -------------------------------------------------------------------------------- /ch6/10.scm: -------------------------------------------------------------------------------- 1 | ;; For list-sum,formulate a succinct representation of the continuations, 2 | ;; like the one for fact/k above. 3 | 4 | (define list-sum 5 | (lambda (lst) 6 | (list-sum/k lst 0))) 7 | 8 | (define list-sum/k 9 | (lambda (lst cont) 10 | (if (null? lst) 11 | cont 12 | (list-sum/k (cdr lst) 13 | (+ (car lst) cont))))) 14 | 15 | (list-sum '()) 16 | (list-sum '(1)) 17 | (list-sum '(1 2 3)) 18 | 19 | 20 | -------------------------------------------------------------------------------- /ch6/05.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/test.scm") 3 | 4 | ;; WOW, using a case as example? 5 | 6 | (let ((x 7 | (if a (p x) (p y)))) 8 | x) 9 | 10 | ;; => 11 | (if a (p x) (p y)) 12 | 13 | (lambda (x y cont) 14 | (p x (lambda (v1) 15 | (cont (if a v1 (p y)))))) 16 | 17 | (lambda (a x y cont) 18 | (p y (lambda (v2) 19 | (p x (lambda (v1) 20 | (cont (if a v1 v2))))))) 21 | -------------------------------------------------------------------------------- /ch1/31.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define interior-node 4 | (lambda (content lnode rnode) 5 | (list content lnode rnode))) 6 | 7 | (define leaf 8 | (lambda (content) 9 | content)) 10 | 11 | (define leaf? 12 | (lambda (bintree) 13 | (not (pair? bintree)))) 14 | 15 | (define lson cadr) 16 | 17 | (define rson caddr) 18 | 19 | (define contents-of 20 | (lambda (bintree) 21 | (if (leaf? bintree) 22 | bintree 23 | (car bintree)))) -------------------------------------------------------------------------------- /ch1/34.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define path 4 | (lambda (n bst) 5 | (cond 6 | ((null? bst) '()) 7 | ((< n (car bst)) (cons 'left (path n (cadr bst)))) 8 | ((> n (car bst)) (cons 'right (path n (caddr bst)))) 9 | ((= n (car bst)) '())))) 10 | 11 | (equal?? (path 17 '(14 (7 () (12 () ())) 12 | (26 (20 (17 () ()) ()) 13 | (31 () ())))) 14 | '(right left left)) 15 | -------------------------------------------------------------------------------- /ch2/04.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;;emtpy-stack? and top is observers 4 | 5 | (define empty-stack 6 | (lambda () 7 | '())) 8 | 9 | (define empty-stack? 10 | (lambda (stack) 11 | (if (equal? stack '()) 12 | #t 13 | #f))) 14 | 15 | (define push 16 | (lambda (stack val) 17 | (cons val stack))) 18 | 19 | (define pop 20 | (lambda (stack) 21 | (cdr stack))) 22 | 23 | (define top 24 | (lambda (stack) 25 | (car stack))) 26 | -------------------------------------------------------------------------------- /ch8/18.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/test.scm") 3 | (load-relative "./base/data-structures.scm") 4 | (load-relative "./base/type-structures.scm") 5 | (load-relative "./base/type-module.scm") 6 | (load-relative "./base/grammar.scm") 7 | (load-relative "./base/renaming.scm") 8 | (load-relative "./base/subtyping.scm") 9 | (load-relative "./base/expand-type.scm") 10 | (load-relative "./base/type-cases.scm") 11 | 12 | ;; code refactor 13 | -------------------------------------------------------------------------------- /ch1/27.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | 5 | (define flatten 6 | (lambda (x) 7 | (cond ((null? x) '()) 8 | ((not (pair? x)) (list x)) 9 | (else (append (flatten (car x)) 10 | (flatten (cdr x))))))) 11 | 12 | (equal?? (flatten '(a b c)) '(a b c)) 13 | (equal?? (flatten '(b ())) '(b)) 14 | (equal?? (flatten '((a) () (b ()) () (c))) '(a b c)) 15 | (equal?? (flatten '((a b) c (((d)) e))) '(a b c d e)) 16 | (equal?? (flatten '(a b (() (c)))) '(a b c)) 17 | -------------------------------------------------------------------------------- /ch4/01.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/store.scm") 3 | (load-relative "./base/explicit-lang.scm") 4 | 5 | (run " let g = proc (dummy) 6 | let counter = newref(0) 7 | in begin 8 | setref(counter, -(deref(counter), -1)); 9 | deref(counter) 10 | end 11 | in let a = (g 11) 12 | in let b = (g 11) 13 | in -(a,b)") 14 | 15 | ;; => (num-val 0) 16 | -------------------------------------------------------------------------------- /ch7/13.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; let x = exp in let-body 3 | ;; bound t_x = t_exp in let-body 4 | 5 | ;; let x = 4 in (x 3) error, x int? or a proc? 6 | 7 | ;; let f = proc(z) z in proc(x) -((f x), 1) 8 | ;; proc(x) type_x -> int 9 | ;; type(exp) type_x -> (type_x -> int) 10 | 11 | ;; let p = zero?(x) in if p then 88 else 99 12 | ;; type(x) = int 13 | ;; type(exp) = int 14 | 15 | ;; let p = proc(z) z in if p then 88 else 99 16 | ;; type(z) = type_x 17 | ;; type(p) = bool 18 | ;; type(exp) = int 19 | -------------------------------------------------------------------------------- /ch1/23.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define list-index-rec 4 | (lambda (pred lst idx) 5 | (if (null? lst) 6 | #f 7 | (if (pred (car lst)) 8 | idx 9 | (list-index-rec pred (cdr lst) (+ idx 1)))))) 10 | 11 | 12 | (define list-index 13 | (lambda (pred lst) 14 | (list-index-rec pred lst 0))) 15 | 16 | 17 | (equal?? (list-index number? '(a 2 (1 3) b 7)) 1) 18 | (equal?? (list-index symbol? '(a (b c) 17 foo)) 0) 19 | (equal?? (list-index symbol? '(1 2 (a b) 3)) #f) 20 | 21 | -------------------------------------------------------------------------------- /ch1/26.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define up 4 | (lambda (lst) 5 | (if (null? lst) 6 | '() 7 | (let ((now (car lst))) 8 | (if (and (list? now) (not (null? now))) 9 | (cons (car now) 10 | (if (null? (cdr now)) 11 | (up (cdr lst)) 12 | (up (cons (cdr now) (cdr lst))))) 13 | (cons now (up (cdr lst)))))))) 14 | 15 | 16 | (equal?? (up '((1 2) (3 4))) '(1 2 3 4)) 17 | (equal?? (up '((x (y)) z)) '(x (y) z)) 18 | (equal?? (up '()) '()) 19 | (equal?? (up '(a b (c))) '(a b c)) 20 | -------------------------------------------------------------------------------- /base/chapter5/letrec-lang/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; require both recursive and register versions. 4 | ;; test with (interp-run-all) or (registers-run-all) 5 | ;; (run-all) will run both. 6 | 7 | (require (prefix interp- "top-interp.scm")) 8 | (require (prefix registers- "top-interp-registers.scm")) 9 | 10 | (provide interp-run registers-run run-all) 11 | 12 | (define run-all 13 | (lambda () 14 | (interp-run-all) 15 | (registers-run-all))) 16 | 17 | ) 18 | -------------------------------------------------------------------------------- /ch1/08.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; this will drop the elements before the first key element 4 | 5 | (define remove-first 6 | (lambda (s los) 7 | (if (null? los) 8 | '() 9 | (if (eqv? (car los) s) 10 | (cdr los) 11 | (remove-first s (cdr los)))))) 12 | 13 | 14 | ;;(remove-first 'c '(b c d e)) 15 | ;;(remove-first 'c '(c d e)) 16 | 17 | (equal?? (remove-first 'c '(b c d e)) '(d e)) 18 | 19 | ;; when first emlemnt is the key element, it's OK 20 | (equal?? (remove-first 'c '(c d e)) '(d e)) 21 | -------------------------------------------------------------------------------- /ch1/32.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | (load "31.scm") 3 | 4 | (define double-tree 5 | (lambda (bintree) 6 | (if (leaf? bintree) 7 | (* 2 bintree) 8 | (interior-node (contents-of bintree) 9 | (double-tree (lson bintree)) 10 | (double-tree (rson bintree)))))) 11 | 12 | (equal?? (double-tree (interior-node 'red 13 | (interior-node 'bar 14 | (leaf 26) 15 | (leaf 12)) 16 | (interior-node 'red 17 | (leaf 11) 18 | (interior-node 'quux 19 | (leaf 117) 20 | (leaf 14))))) 21 | '(red (bar 52 24) (red 22 (quux 234 28)))) -------------------------------------------------------------------------------- /base/chapter8/simplemodules/expand-type.scm: -------------------------------------------------------------------------------- 1 | (module expand-type (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") 4 | (require "static-data-structures.scm") 5 | 6 | (provide expand-type) 7 | (provide expand-iface) 8 | 9 | ;;;;;;;;;;;;;;;; expand-type ;;;;;;;;;;;;;;;; 10 | 11 | ;; these are stubs. They will be replaced by something more 12 | ;; interesting in abstract-types-lang. 13 | 14 | (define expand-type (lambda (ty tenv) ty)) 15 | (define expand-iface (lambda (m-name iface tenv) iface)) 16 | 17 | ) 18 | -------------------------------------------------------------------------------- /ch1/21.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define product 4 | (lambda (lsta lstb) 5 | (cond ((null? lsta) '()) 6 | (else (append (product-symbol (car lsta) lstb) 7 | (product (cdr lsta) lstb)))))) 8 | 9 | (define product-symbol 10 | (lambda (sym lst) 11 | (cond ((null? lst) '()) 12 | (else (cons (list sym (car lst)) 13 | (product-symbol sym (cdr lst))))))) 14 | 15 | (equal?? (product '(a b c) '(x y)) '((a x) (a y) (b x) (b y) (c x) (c y))) 16 | (equal?? (product '(x y z) '(e f g)) '((x e) (x f) (x g) (y e) (y f) (y g) (z e) (z f) (z g))) -------------------------------------------------------------------------------- /ch1/22.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define filter-in 4 | (lambda (pred lst) 5 | (if (null? lst) 6 | '() 7 | (if (pred (car lst)) 8 | (cons (car lst) 9 | (filter-in pred (cdr lst))) 10 | (filter-in pred (cdr lst)))))) 11 | 12 | 13 | ;;(car '(a 2 (1 3) b 7)) 14 | ;;(number? (car '(a 2 (1 3) b 7))) 15 | (filter-in number? '(a)) 16 | (filter-in number? '(1)) 17 | (equal?? (filter-in number? '(a 2 (1 3) b 7)) '(2 7)) 18 | (equal?? (filter-in symbol? '(a (b c) 17 foo)) '(a foo)) 19 | (equal?? (filter-in number? '()) '()) 20 | 21 | -------------------------------------------------------------------------------- /ch1/12.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define subst 4 | (lambda (new old slist) 5 | (if (null? slist) 6 | '() 7 | (cons 8 | (let ((sexp (car slist))) 9 | (if (symbol? sexp) 10 | (if (eqv? sexp old) 11 | new 12 | sexp) 13 | (subst new old sexp))) 14 | (subst new old (cdr slist)))))) 15 | 16 | 17 | (equal?? (subst 'a 'b '(a b c d e)) '(a a c d e)) 18 | (equal?? (subst 'a 'b '(b)) '(a)) 19 | (equal?? (subst 'a 'b '(b b b)) '(a a a)) 20 | 21 | (equal?? (subst 's 'a '((a b) c d s)) '((s b) c d s)) 22 | -------------------------------------------------------------------------------- /ch1/28.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define merge 4 | (lambda (loi1 loi2) 5 | (cond ((and (null? loi1) (not (null? loi2))) 6 | loi2) 7 | ((and (null? loi2) (not (null? loi1))) 8 | loi1) 9 | (else (let ((first1 (car loi1)) 10 | (first2 (car loi2))) 11 | (if (< first1 first2) 12 | (cons first1 (merge (cdr loi1) loi2)) 13 | (cons first2 (merge loi1 (cdr loi2))))))))) 14 | 15 | 16 | (equal?? (merge '(1 4) '(1 2 8)) '(1 1 2 4 8)) 17 | (equal?? (merge '(35 62 81 90 91) '(3 83 85 90)) 18 | '(3 35 62 81 83 85 90 90 91)) 19 | -------------------------------------------------------------------------------- /ch9/12.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/classes/test.scm") 3 | (load-relative "./base/classes/store.scm") 4 | (load-relative "./base/classes/data-structures.scm") 5 | (load-relative "./base/classes/environments.scm") 6 | (load-relative "./base/classes/lang.scm") 7 | (load-relative "./base/classes/interp.scm") 8 | (load-relative "./base/classes/classes.scm") 9 | (load-relative "./base/classes/class-cases.scm") 10 | 11 | ;; add private, protected, public property for method of a class 12 | ;; add pri-fields pro-fields pub-fields 13 | ;; won't do that now. 14 | -------------------------------------------------------------------------------- /ch1/07.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; we add a wrapper at nth-element-rec 4 | 5 | (define report-list-too-short 6 | (lambda (list nth) 7 | (error 'nth-element 8 | "List ~s too short by ~s elements .~%" list nth))) 9 | 10 | (define nth-element-rec 11 | (lambda (lst n) 12 | (if (null? lst) 13 | #f 14 | (if (zero? n) 15 | (car lst) 16 | (nth-element-rec (cdr lst) (- n 1)))))) 17 | 18 | (define nth-element 19 | (lambda (lst n) 20 | (let ((ans (nth-element-rec lst n))) 21 | (if (not ans) 22 | (report-list-too-short lst n) 23 | ans)))) 24 | -------------------------------------------------------------------------------- /ch1/13.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define subst-in-s-exp 4 | (lambda (new old sexp) 5 | (if (symbol? sexp) 6 | (if (eqv? sexp old) new sexp) 7 | (subst new old sexp)))) 8 | 9 | (define subst 10 | (lambda (new old slist) 11 | (if (null? slist) 12 | '() 13 | (map (lambda (item) (subst-in-s-exp new old item)) slist)))) 14 | 15 | (equal?? (subst 'a 'b '(a b c d e)) '(a a c d e)) 16 | (equal?? (subst 'a 'b '(b)) '(a)) 17 | (equal?? (subst 'a 'b '(b b b)) '(a a a)) 18 | (equal?? (subst 's 'a '((a b) c d s)) '((s b) c d s)) 19 | -------------------------------------------------------------------------------- /base/chapter2/utils.scm: -------------------------------------------------------------------------------- 1 | (module utils (lib "eopl.ss" "eopl") 2 | 3 | ;; a very simple macro for inline testing 4 | 5 | (provide equal?? report-unit-tests-completed) 6 | 7 | ;; simple-minded magic for tests 8 | (define-syntax equal?? 9 | (syntax-rules () 10 | ((_ x y) 11 | (let ((x^ x) (y^ y)) 12 | (if (not (equal? x y)) 13 | (eopl:error 'equal?? 14 | "~s is not equal to ~s" 'x 'y)))))) 15 | 16 | (define report-unit-tests-completed 17 | (lambda (fn-name) 18 | (eopl:printf "unit tests completed: ~s~%" fn-name))) 19 | 20 | ) -------------------------------------------------------------------------------- /base/chapter5/thread-lang/queues.scm: -------------------------------------------------------------------------------- 1 | (module queues (lib "eopl.ss" "eopl") 2 | 3 | (provide (all-defined)) 4 | 5 | ;; queues 6 | 7 | ;; We maintain the queue by adding to the end and dequeuing from the 8 | ;; front. 9 | 10 | ;; exercise: enqueue is expensive, since it uses append. Do 11 | ;; something better than this. 12 | 13 | (define empty-queue 14 | (lambda () 15 | '())) 16 | 17 | (define empty? null?) 18 | 19 | (define enqueue 20 | (lambda (q val) 21 | (append q (list val)))) 22 | 23 | (define dequeue 24 | (lambda (q f) 25 | (f (car q) (cdr q)))) 26 | 27 | ) -------------------------------------------------------------------------------- /ch9/42.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/typed-oo/lang.scm") 3 | (load-relative "./base/typed-oo/test.scm") 4 | (load-relative "./base/typed-oo/store.scm") 5 | (load-relative "./base/typed-oo/interp.scm") 6 | (load-relative "./base/typed-oo/checker.scm") 7 | (load-relative "./base/typed-oo/environments.scm") 8 | (load-relative "./base/typed-oo/classes.scm") 9 | (load-relative "./base/typed-oo/static-classes.scm") 10 | (load-relative "./base/typed-oo/data-structures.scm") 11 | (load-relative "./base/typed-oo/static-data-structures.scm") 12 | (load-relative "./base/typed-oo/tests.scm") 13 | 14 | (define debug? (make-parameter #f)) 15 | -------------------------------------------------------------------------------- /ch1/29.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; using insert sort here 4 | 5 | (define insert 6 | (lambda (lst elem) 7 | (cond ((null? lst) (list elem)) 8 | ((< elem (car lst)) 9 | (cons elem lst)) 10 | (else (cons (car lst) 11 | (insert (cdr lst) elem)))))) 12 | 13 | (define sort-rec 14 | (lambda (prev now) 15 | (if (null? now) 16 | prev 17 | (sort-rec (insert prev (car now)) 18 | (cdr now))))) 19 | (define sort 20 | (lambda (lst) 21 | (sort-rec '() lst))) 22 | 23 | 24 | (equal?? (sort '()) '()) 25 | (equal?? (sort '(1 2 3 4)) '(1 2 3 4)) 26 | (equal?? (sort '(4 3 2 1)) '(1 2 3 4)) 27 | (equal?? (sort '(8 2 5 2 3)) '(2 2 3 5 8)) 28 | -------------------------------------------------------------------------------- /ch1/18.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define swapper 4 | (lambda (l r list) 5 | (if (null? list) 6 | '() 7 | (let ((now (car list))) 8 | (if (symbol? now) 9 | (cond 10 | ((equal? now l) 11 | (cons r (swapper l r (cdr list)))) 12 | ((equal? now r) 13 | (cons l (swapper l r (cdr list)))) 14 | (else 15 | (cons now (swapper l r (cdr list))))) 16 | (cons (swapper l r now) 17 | (swapper l r (cdr list)))))))) 18 | 19 | (equal?? (swapper 'a 'd '(a b c d)) '(d b c a)) 20 | 21 | (equal?? (swapper 'a 'd '(a d () c d)) 22 | '(d a () c a)) 23 | 24 | (equal?? (swapper 'x 'y '((x) y (z (x)))) 25 | '((y) x (z (y)))) 26 | -------------------------------------------------------------------------------- /ch6/27.scm: -------------------------------------------------------------------------------- 1 | 2 | (load-relative "../libs/init.scm") 3 | (load-relative "./base/test.scm") 4 | (load-relative "./base/cps.scm") 5 | (load-relative "./base/data-structures.scm") 6 | (load-relative "./base/cps-cases.scm") 7 | (load-relative "./base/cps-lang.scm") 8 | (load-relative "./base/base-iterp.scm") 9 | 10 | ;; TODO 11 | 12 | ;; cps-of-let-exp : Var * InpExp * InpExp * SimpleExp -> TfExp 13 | (define cps-of-let-exp 14 | (lambda (id rhs body k-exp) 15 | (cps-of-exps (list rhs) 16 | (lambda (new-rands) 17 | (cps-let-exp id 18 | (car new-rands) 19 | (cps-of-exp body k-exp)))))) 20 | -------------------------------------------------------------------------------- /ch3/24.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/environments.scm") 3 | (load-relative "./base/proc-lang.scm") 4 | ;; I think this is a little difficult, see the new stuff 5 | 6 | ;; new stuff 7 | (run "let even-iter = proc (o) proc(e) proc(num) 8 | if zero?(num) 9 | then 1 10 | else 11 | (((o o) e) -(num, 1)) 12 | in let odd-iter = proc (o) proc(e) proc(num) 13 | if zero?(num) 14 | then 0 15 | else 16 | (((e o) e) -(num, 1)) 17 | in let odd = proc(num) (((odd-iter odd-iter) even-iter) num) 18 | in let even = proc(num) (((even-iter odd-iter) even-iter) num) 19 | in (odd 6)") 20 | -------------------------------------------------------------------------------- /ch1/20.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define count-occurs-rec 4 | (lambda (val list cnt) 5 | (if (null? list) 6 | cnt 7 | (if (list? (car list)) 8 | (count-occurs-rec val (cdr list) 9 | (+ (count-occurs-rec val (car list) 0) cnt)) 10 | (if (equal? (car list) val) 11 | (count-occurs-rec val (cdr list) (+ cnt 1)) 12 | (count-occurs-rec val (cdr list) cnt)))))) 13 | 14 | 15 | (define count-occurs 16 | (lambda (val list) 17 | (count-occurs-rec val list 0))) 18 | 19 | 20 | 21 | (equal?? (count-occurs 'x '((f x) y (((x z) x)))) 3) 22 | 23 | (equal?? (count-occurs 'x '((f x) y (((x z) () x)))) 3) 24 | (equal?? (count-occurs 'w '((f x) y (((x z) x)))) 0) 25 | -------------------------------------------------------------------------------- /ch2/24.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define-datatype bintree bintree? 4 | (leaf-node 5 | (num integer?)) 6 | (interior-node 7 | (key symbol?) 8 | (left bintree?) 9 | (right bintree?))) 10 | 11 | 12 | 13 | (define bintree-to-list 14 | (lambda (tree) 15 | (cases bintree tree 16 | (leaf-node (num) 17 | (list 'leaf-node num)) 18 | (interior-node (key left right) 19 | (list 'interior-node 20 | key 21 | (bintree-to-list left) 22 | (bintree-to-list right)))))) 23 | 24 | 25 | (define tree 26 | (interior-node 'a (leaf-node 3) (leaf-node 4))) 27 | 28 | (equal?? (bintree-to-list tree) 29 | '(interior-node a (leaf-node 3) (leaf-node 4))) 30 | -------------------------------------------------------------------------------- /ch9/oo.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/typed-oo/lang.scm") 3 | (load-relative "./base/typed-oo/test.scm") 4 | (load-relative "./base/typed-oo/store.scm") 5 | (load-relative "./base/typed-oo/interp.scm") 6 | (load-relative "./base/typed-oo/checker.scm") 7 | (load-relative "./base/typed-oo/environments.scm") 8 | (load-relative "./base/typed-oo/classes.scm") 9 | (load-relative "./base/typed-oo/static-classes.scm") 10 | (load-relative "./base/typed-oo/data-structures.scm") 11 | (load-relative "./base/typed-oo/static-data-structures.scm") 12 | (load-relative "./base/typed-oo/tests.scm") 13 | 14 | (define debug? (make-parameter #f)) 15 | 16 | (run-all) 17 | (check-all) 18 | -------------------------------------------------------------------------------- /ch9/03.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; ((c3 3 | ;; #(struct:a-class c2 (x%2 y%1 y x z) %fields shared 4 | ;; ((initialize #(struct:a-method () 5 | ;; #(struct:begin-exp ...) c2 (x%2 y%1 y x z))) 6 | ;; (m3 #(struct:a-method () 7 | ;; #(struct:diff-exp ...)) c2 (x%2 y%1 y x z)) 8 | ;; (initialize #(struct:a-method ...)) 9 | ;; (m1 #(struct:a-method (u v) 10 | ;; #(struct:diff-exp ...) c1 (x y%1 y))) 11 | ;; (m3 #(struct:a-method ...)) 12 | ;; (initialize #(struct:a-method ...)) %methods shared 13 | ;; (m1 #(struct:a-method ...)) 14 | ;; (m2 #(struct:a-method () 15 | ;; #(struct:method-call-exp 16 | ;; #(struct:self-exp) m3 ()) object (x y)))))) 17 | -------------------------------------------------------------------------------- /ch6/22.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; Generating better code when K is already proc-exp for (K simp) 3 | 4 | (load-relative "../libs/init.scm") 5 | (load-relative "./base/test.scm") 6 | (load-relative "./base/cps.scm") 7 | (load-relative "./base/data-structures.scm") 8 | (load-relative "./base/cps-cases.scm") 9 | (load-relative "./base/cps-lang.scm") 10 | (load-relative "./base/base-iterp.scm") 11 | 12 | ;; make-send-to-cont : SimpleExp * SimpleExp -> TfExp 13 | (define make-send-to-cont 14 | (lambda (cont bexp) 15 | (cases simple-expression cont 16 | (cps-proc-exp (vars body) 17 | (cps-let-exp (car vars) bexp body)) 18 | (else 19 | (cps-call-exp cont (list bexp)))))) 20 | 21 | 22 | (run-all) 23 | -------------------------------------------------------------------------------- /ch8/19.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; finish module procedure with to-two 4 | 5 | module from-int-maker 6 | interface 7 | ((ints : [opaque t 8 | zero : t 9 | succ : (t -> t) 10 | pred : (t -> t) 11 | is-zero : (t -> bool)]) 12 | => [from-int : (int -> from ints take t)]) 13 | body 14 | module-proc (ints : [opaque t 15 | zero : t 16 | succ : (t -> t) 17 | pred : (t -> t) 18 | is-zero : (t -> bool)]) 19 | [to-int 20 | = let z? = from ints take is-zero 21 | in let p = from ints take pred 22 | in letrec int to-int (x : from ints take t) 23 | in to-int 24 | 25 | to-two 26 | = (from ints take succ 27 | (from ints take succ 28 | from ints take zero))] 29 | -------------------------------------------------------------------------------- /ch1/36.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define number-elements 4 | (lambda (lst) 5 | (if (null? lst) '() 6 | (g (list 0 (car lst)) (number-elements (cdr lst)))))) 7 | 8 | (define g 9 | (lambda (node lst) 10 | (if (null? lst) 11 | (list node) 12 | (cons node 13 | (g-plus-one (car lst) (cdr lst)))))) 14 | 15 | (define g-plus-one 16 | (lambda (node lst) 17 | (if (null? lst) 18 | (list (list (+ (car node) 1) (cadr node))) 19 | (cons (list (+ (car node) 1) (cadr node)) 20 | (g-plus-one (car lst) (cdr lst)))))) 21 | 22 | (equal?? (number-elements '(a b c d)) '((0 a) (1 b) (2 c) (3 d))) 23 | 24 | (equal?? (number-elements '(az by cx dw ev)) '((0 az) (1 by) (2 cx) (3 dw) (4 ev))) 25 | -------------------------------------------------------------------------------- /ch8/22.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | module equality-maker 4 | interface 5 | ((ints : [opaque t 6 | zero : t 7 | succ : (t -> t) 8 | pred : (t -> t) 9 | is-zero : (t -> bool)]) 10 | => [equal : (from ints take t 11 | -> (from ints take t 12 | -> bool))]) 13 | body 14 | [ 15 | equal = let ty = from ints take t 16 | in let z? = from ints take is-zero 17 | in let s = from ints take succ 18 | in let p = from ints take pred 19 | in letrec (ty -> bool) equal(x : ty) = 20 | proc(y : ty) 21 | if z?(x) and z?(y) then #t 22 | else if (or (and z?(x) (not z?(y))) 23 | (and z?(y) (not z?(x)))) 24 | then #f 25 | else ((equal (pred x)) (pred y)) 26 | in equal] 27 | -------------------------------------------------------------------------------- /ch6/02.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; Prove by induction on n that for any g, (fib/k n g) = (g (fib n)). 3 | 4 | ;; initial step: 5 | ;; (fib/k 1 g) = (g 1) = (g (fib 1)) stands true 6 | 7 | ;; assume (fib/k n g) = (g fib(n)) 8 | 9 | ;; (fib/k n+1 g) => (g fib(n+1)) 10 | 11 | ;; => 12 | 13 | ;; (fib/k n (lambda (v1) 14 | ;; (fib/k (n-1) 15 | ;; (lambda (v2) 16 | ;; (g (v1 + v2)))))) 17 | 18 | ;; (lambda (v1) 19 | ;; (fib/k (n-1) 20 | ;; (lambda (v2) 21 | ;; (g (v1 + v2)))) 22 | ;; (fib/k n)) 23 | 24 | ;; (fib/k (n-1) (lambda (v2) 25 | ;; (g ((fib/k n) + v2)))) 26 | 27 | ;; (lambda (v2) 28 | ;; (g ((fib/k n) + v2)) 29 | ;; (fib/k (n-1))) 30 | 31 | ;; (g ((fib/k n) + (fib/k (n - 1)))) 32 | 33 | ;; (g (fibd/k (n + 1))) 34 | 35 | 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /ch4/base/pair-v2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define mutpair? 3 | (lambda (v) 4 | (reference? v))) 5 | 6 | ;; make-pair : ExpVal * ExpVal -> MutPair 7 | ;; Page: 129 8 | (define make-pair 9 | (lambda (val1 val2) 10 | (let ((ref1 (newref val1))) 11 | (let ((ref2 (newref val2))) 12 | ref1)))) 13 | 14 | ;; left : MutPair -> ExpVal 15 | ;; Page: 129 16 | (define left 17 | (lambda (p) 18 | (deref p))) 19 | 20 | ;; right : MutPair -> ExpVal 21 | ;; Page: 129 22 | (define right 23 | (lambda (p) 24 | (deref (+ 1 p)))) 25 | 26 | ;; setleft : MutPair * ExpVal -> Unspecified 27 | ;; Page: 129 28 | (define setleft 29 | (lambda (p val) 30 | (setref! p val))) 31 | 32 | ;; setright : MutPair * Expval -> Unspecified 33 | ;; Page: 129 34 | (define setright 35 | (lambda (p val) 36 | (setref! (+ 1 p) val))) 37 | -------------------------------------------------------------------------------- /base/chapter3/lexaddr-lang/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | (provide init-nameless-env empty-nameless-env extend-nameless-env 5 | apply-nameless-env) 6 | 7 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 8 | 9 | ;; init-env : () -> Nameless-env 10 | 11 | ;; (init-env) builds an environment in which i is bound to the 12 | ;; expressed value 1, v is bound to the expressed value 5, and x is 13 | ;; bound to the expressed value 10. 14 | 15 | (define init-nameless-env 16 | (lambda () 17 | (extend-nameless-env 18 | (num-val 1) ; was i 19 | (extend-nameless-env 20 | (num-val 5) ; was v 21 | (extend-nameless-env 22 | (num-val 10) ; was x 23 | (empty-nameless-env)))))) 24 | 25 | 26 | ) -------------------------------------------------------------------------------- /ch2/27.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | ;; I won't give a picture for the AST, but to construct such too AST, the code is 5 | ;; as below 6 | 7 | (define id? 8 | (lambda (symbol) 9 | (not (and (symbol? symbol) 10 | (eqv? symbol 'lambda))))) 11 | 12 | (define-datatype lc-expr lc-expr? 13 | (var-expr 14 | (var id?)) 15 | (lambda-expr 16 | (bound-var id?) 17 | (body lc-expr?)) 18 | (app-expr 19 | (rator lc-expr?) 20 | (rand lc-expr?))) 21 | 22 | 23 | (define expA 24 | (app-expr 25 | (lambda-expr 26 | (var-expr 'a) 27 | (var-expr 'b)) 28 | (var-expr 'c))) 29 | 30 | (define expB 31 | (lambda-expr 'x 32 | (lambda-expr 'y 33 | (lambda-expr 'x 34 | (app-expr 35 | (lambda-expr 'x 36 | (app-expr (var-expr 'x) 37 | (var-expr 'y))) 38 | (var-expr 'x)))))) 39 | -------------------------------------------------------------------------------- /ch2/05.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;;EOPL excerice 2.5 4 | 5 | (define empty-env 6 | (lambda() '())) 7 | 8 | (define extend-env 9 | (lambda (var val env) 10 | (cons (cons var val) 11 | env))) 12 | 13 | (define apply-env 14 | (lambda (env search-var) 15 | (cond 16 | ((null? env) 17 | (report-no-binding-found search-var)) 18 | ((eqv? (caar env) search-var) 19 | (cdr (car env))) 20 | (else 21 | (apply-env (cdr env) search-var))))) 22 | 23 | (define report-no-binding-found 24 | (lambda (search-var) 25 | (error 'apply-env "No binding for: " search-var))) 26 | 27 | (define e 28 | (extend-env 'd 6 29 | (extend-env 'y 8 30 | (extend-env 'x 7 31 | (extend-env 'y 14 32 | (empty-env)))))) 33 | 34 | (equal?? (apply-env e 'd) 6) 35 | (equal?? (apply-env e 'y) 8) 36 | (equal?? (apply-env e 'x) 7) 37 | (equal?? (apply-env e 'd) 6) 38 | -------------------------------------------------------------------------------- /ch3/25.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/environments.scm") 3 | 4 | (load-relative "./base/proc-lang.scm") 5 | 6 | (run "let makerec = proc (f) 7 | let d = proc (x) 8 | proc (z) ((f (x x)) z) 9 | in proc (n) ((f (d d)) n) 10 | in let maketimes4 = proc (f) proc (x) 11 | if zero?(x) 12 | then 0 13 | else -((f -(x,1)), -4) 14 | in let times4 = (makerec maketimes4) in (times4 3)") 15 | 16 | ;; (run " let makerec = proc (f) 17 | ;; let d = proc (x) (f (x x)) 18 | ;; in (f (d d)) 19 | ;; in let maketimes4 = proc (f) proc (x) 20 | ;; if zero?(x) 21 | ;; then 0 22 | ;; else -((f -(x,1)), -4) 23 | ;; in let times4 = (makerec maketimes4) in (times4 3)") 24 | 25 | ;; -> (num-val 12) 26 | -------------------------------------------------------------------------------- /ch1/33.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | (load "31.scm") 3 | 4 | (define mark-leaves-with-red-depth 5 | (lambda (btree) 6 | (mark-leaves-with-red-accumulated btree 0))) 7 | 8 | (define mark-leaves-with-red-accumulated 9 | (lambda (btree n) 10 | (cond ((leaf? btree) n) 11 | ((eq? (contents-of btree) 'red) 12 | (interior-node 'red 13 | (mark-leaves-with-red-accumulated (lson btree) (+ n 1)) 14 | (mark-leaves-with-red-accumulated (rson btree) (+ n 1)))) 15 | (else 16 | (interior-node (contents-of btree) 17 | (mark-leaves-with-red-accumulated (lson btree) n) 18 | (mark-leaves-with-red-accumulated (rson btree) n)))))) 19 | 20 | (equal?? (mark-leaves-with-red-depth 21 | (interior-node 'red 22 | (interior-node 'bar 23 | (leaf 26) 24 | (leaf 12)) 25 | (interior-node 'red 26 | (leaf 11) 27 | (interior-node 'quux 28 | (leaf 117) 29 | (leaf 14))))) 30 | '(red 31 | (bar 1 1) 32 | (red 2 (quux 2 2)))) -------------------------------------------------------------------------------- /ch1/30.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; using insert sort here 4 | 5 | (define insert 6 | (lambda (lst elem pred) 7 | (cond ((null? lst) (list elem)) 8 | ((pred elem (car lst)) 9 | (cons elem lst)) 10 | (else (cons (car lst) 11 | (insert (cdr lst) elem pred)))))) 12 | 13 | (define sort-rec 14 | (lambda (prev now pred) 15 | (if (null? now) 16 | prev 17 | (sort-rec (insert prev (car now) pred) 18 | (cdr now) 19 | pred)))) 20 | 21 | (define sort/predicate 22 | (lambda (pred lst) 23 | (sort-rec '() lst pred))) 24 | 25 | 26 | (equal?? (sort/predicate < '(8 2 5 2 3)) '(2 2 3 5 8)) 27 | (equal?? (sort/predicate > '(8 2 5 2 3)) '(8 5 3 2 2)) 28 | 29 | (equal?? (sort/predicate < '()) '()) 30 | (equal?? (sort/predicate < '(1 2 3 4)) '(1 2 3 4)) 31 | (equal?? (sort/predicate < '(4 3 2 1)) '(1 2 3 4)) 32 | (equal?? (sort/predicate < '(8 2 5 2 3)) '(2 2 3 5 8)) 33 | -------------------------------------------------------------------------------- /ch2/12.scm: -------------------------------------------------------------------------------- 1 | (load "/Users/kang/code/eopl/libs/scheme48-init.scm") 2 | 3 | (define empty-stack 4 | (lambda() 5 | (lambda (cmd) 6 | (cond 7 | ((eqv? cmd 'top) 8 | (error "try top on empty stack")) 9 | ((eqv? cmd 'pop) 10 | (error "try pop on empty stack")) 11 | (else 12 | (error "unknow cmd on stack")))))) 13 | 14 | (define push 15 | (lambda (saved-stack var) 16 | (lambda (cmd) 17 | (cond 18 | ((eqv? cmd 'top) var) 19 | ((eqv? cmd 'pop) saved-stack) 20 | (else 21 | (error "error cmd")))))) 22 | 23 | (define pop 24 | (lambda (stack) 25 | (stack 'pop))) 26 | 27 | (define top 28 | (lambda (stack) 29 | (stack 'top))) 30 | 31 | 32 | (define e (empty-stack)) 33 | (define x1 (push e 1)) 34 | (define x2 (push x1 2)) 35 | (define x3 (push x2 3)) 36 | 37 | (equal?? (top (pop x2)) 1) 38 | (equal?? (top x2) 2) 39 | (equal?? (top x3) 3) 40 | (equal?? (top (pop (pop x3))) 1) 41 | -------------------------------------------------------------------------------- /ch7/01.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; 1. proc (x) -(x,3) 3 | ;; (int -> int) 4 | 5 | ;; 2. proc (f) proc (x) -((f x), 1) 6 | ;; ((t -> t) -> (t -> int)) 7 | 8 | ;; 3. proc (x) x 9 | ;; (t -> t) 10 | 11 | ;; 4. proc (x) proc (y) (x y). 12 | ;; ((t -> t) -> (t -> t)) 13 | 14 | ;; 5. proc (x) (x 3) 15 | ;; (t -> t) 16 | 17 | ;; 6. proc (x) (x x) 18 | ;; (t -> t) 19 | 20 | ;; 7. proc (x) if x then 88 else 99 21 | ;; (bool -> int) 22 | 23 | ;; 8. proc (x) proc (y) if x then y else 99 24 | ;; have no type 25 | 26 | ;; 9. (proc (p) if p then 88 else 99 33) 27 | ;; int 28 | 29 | ;; 10. (proc (p) if p then 88 else 99 proc (z) z) 30 | ;; have no type 31 | 32 | ;; 11. proc (f) proc (g) 33 | ;; proc (p) 34 | ;; proc (x) if (p (f x)) then (g 1) else -((f x),1) 35 | ;; have no type 36 | 37 | ;; 12. proc (x) proc(p) 38 | ;; proc (f) 39 | ;; if (p x) then -(x,1) else (f p) 40 | ;; have no type 41 | 42 | ;; 13. proc (f) 43 | ;; let d = proc (x) 44 | ;; proc (z) ((f (x x)) z) 45 | ;; in proc (n) ((f (d d)) n) 46 | ;; ((t->t) -> (t->t)) 47 | -------------------------------------------------------------------------------- /ch7/15.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; Write down a rule for doing type inference for a letrec expression. 4 | ;; Your rule should handle multiple declarations in a letrec. Using your rule, 5 | ;; derive types for each of the following expressions, or determine that no such type 6 | ;; exists: 7 | ;; 1. letrec ? f (x : ?) 8 | ;; = if zero?(x) then 0 else -((f -(x,1)), -2) 9 | ;; in f 10 | 11 | ;; type(f) = (int -> int) 12 | 13 | ;; 2. letrec ? even (x : ?) 14 | ;; = if zero?(x) then 1 else (odd -(x,1)) 15 | ;; ? odd (x : ?) 16 | ;; = if zero?(x) then 0 else (even -(x,1)) 17 | ;; in (odd 13) 18 | 19 | ;; type(even) = (int -> int) 20 | ;; type(odd) = (int -> int) 21 | ;; type(exp) = int 22 | 23 | ;; 3. letrec ? even (odd : ?) 24 | ;; = proc (x) if zero?(x) 25 | ;; then 1 26 | ;; else (odd -(x,1)) 27 | ;; in letrec ? odd (x : ?) = 28 | ;; if zero?(x) 29 | ;; then 0 30 | ;; else ((even odd) -(x,1)) 31 | ;; in (odd 13) 32 | 33 | ;; type(even) = (int -> int) 34 | ;; type(odd) = (int -> (int -> int)) 35 | ;; type(exp) = int 36 | -------------------------------------------------------------------------------- /ch2/09.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | (define empty-env 5 | (lambda() '())) 6 | 7 | (define extend-env 8 | (lambda (var val env) 9 | (cons (cons var val) 10 | env))) 11 | 12 | (define apply-env 13 | (lambda (env search-var) 14 | (cond 15 | ((null? env) 16 | (report-no-binding-found search-var)) 17 | ((eqv? (caar env) search-var) 18 | (cdr (car env))) 19 | (else 20 | (apply-env (cdr env) search-var))))) 21 | 22 | (define report-no-binding-found 23 | (lambda (search-var) 24 | (error 'apply-env "No binding for: " search-var))) 25 | 26 | 27 | (define has-binding? 28 | (lambda (env var) 29 | (cond 30 | ((null? env) #f) 31 | ((eqv? (caar env) var) #t) 32 | (else 33 | (has-binding? (cdr env) var))))) 34 | 35 | 36 | (define e 37 | (extend-env 'd 6 38 | (extend-env 'y 8 39 | (extend-env 'x 7 40 | (extend-env 'y 14 41 | (empty-env)))))) 42 | 43 | (equal?? (has-binding? e 'd) #t) 44 | (equal?? (has-binding? e 'y) #t) 45 | (equal?? (has-binding? e 'x) #t) 46 | (equal?? (has-binding? e 'z) #f) 47 | -------------------------------------------------------------------------------- /ch4/base/pair-v1.scm: -------------------------------------------------------------------------------- 1 | ;; Page: 124 2 | (define-datatype mutpair mutpair? 3 | (a-pair 4 | (left-loc reference?) 5 | (right-loc reference?))) 6 | 7 | ;; make-pair : ExpVal * ExpVal -> MutPair 8 | ;; Page: 124 9 | (define make-pair 10 | (lambda (val1 val2) 11 | (a-pair 12 | (newref val1) 13 | (newref val2)))) 14 | 15 | ;; left : MutPair -> ExpVal 16 | ;; Page: 125 17 | (define left 18 | (lambda (p) 19 | (cases mutpair p 20 | (a-pair (left-loc right-loc) 21 | (deref left-loc))))) 22 | 23 | ;; right : MutPair -> ExpVal 24 | ;; Page: 125 25 | (define right 26 | (lambda (p) 27 | (cases mutpair p 28 | (a-pair (left-loc right-loc) 29 | (deref right-loc))))) 30 | 31 | ;; setleft : MutPair * ExpVal -> Unspecified 32 | ;; Page: 125 33 | (define setleft 34 | (lambda (p val) 35 | (cases mutpair p 36 | (a-pair (left-loc right-loc) 37 | (setref! left-loc val))))) 38 | 39 | ;; setright : MutPair * ExpVal -> Unspecified 40 | ;; Page: 125 41 | (define setright 42 | (lambda (p val) 43 | (cases mutpair p 44 | (a-pair (left-loc right-loc) 45 | (setref! right-loc val))))) 46 | -------------------------------------------------------------------------------- /ch6/29.scm: -------------------------------------------------------------------------------- 1 | ;; Consider this variant of cps-of-exps 2 | (load-relative "../libs/init.scm") 3 | (load-relative "./base/test.scm") 4 | (load-relative "./base/cps.scm") 5 | (load-relative "./base/data-structures.scm") 6 | (load-relative "./base/cps-cases.scm") 7 | (load-relative "./base/cps-lang.scm") 8 | (load-relative "./base/base-iterp.scm") 9 | 10 | ;; This version of cps-of-exps is continuation passing style, 11 | ;; like the optimized version fact, acc used as cont. 12 | 13 | (define cps-of-exps 14 | (lambda (exps builder) 15 | (let cps-of-rest ((exps exps) (acc '())) 16 | ;; cps-of-rest : Listof(InpExp) × Listof(SimpleExp) → TfExp 17 | (cond 18 | ((null? exps) (builder (reverse acc))) 19 | ((inp-exp-simple? (car exps)) 20 | (cps-of-rest (cdr exps) 21 | (cons 22 | (cps-of-simple-exp (car exps)) 23 | acc))) 24 | (else 25 | (let ((var (fresh-identifier 'var))) 26 | (cps-of-exp (car exps) 27 | (cps-proc-exp 28 | (list var) 29 | (cps-of-rest 30 | (cdr exps) 31 | (cons (cps-of-simple-exp (var-exp var)) acc)))))))))) 32 | 33 | (run-all) 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | ## My answers for EOPL3 3 | 4 | ### Base/libs 5 | 6 | This is all the original code from the book. I have some modification on utilities. 7 | 8 | ### Ch 9 | 10 | My answer code for the exercises, NOT all problem are solved, so any complement is welcome. 11 | 12 | Usually the function call (run-all) and (check-all) will run all the test-cases. 13 | 14 | Before chapter 8, I put all the code for an interpreter in single file. 15 | 16 | Begin with chapter 8, I put base code in the base directory of each chapter, and load it when necessary. 17 | 18 | ### Note 19 | The code are tested on Chicken Scheme with chicken-slime in Emacs, 20 | and assumed to be runnable for most other Scheme implementation. 21 | 22 | ### Contribution 23 | Please fire an issue or give Pull Request for any bug, Thanks! 24 | 25 | mailto:moorekang@gmail.com 26 | 27 | ### How to run and debug these programs 28 | * Install [Chicken Scheme](http://www.call-cc.org/). 29 | * Clone this Github repo to your local directory (e.g. ~/Desktop/). 30 | * Access to the directory of a chapter (e.g. ~/Desktop/eopl/ch3). 31 | * Run the following command on your terminal: csi xxx.scm 32 | -------------------------------------------------------------------------------- /ch2/31.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define-datatype prefix-exp prefix-exp? 4 | (const-exp 5 | (num integer?)) 6 | (diff-exp 7 | (operand1 prefix-exp?) 8 | (operand2 prefix-exp?))) 9 | 10 | (define make-prefix-exp 11 | (lambda (lst) 12 | (if (null? lst) 13 | '() 14 | (if (number? (car lst)) 15 | (cons (const-exp (car lst)) 16 | (cdr lst)) 17 | (if (eqv? (car lst) '-) 18 | (if (null? (cdr lst)) 19 | (error 'make-prefix-exp "need operand") 20 | (let* ((next (make-prefix-exp (cdr lst))) 21 | (op1 (car next)) 22 | (next (make-prefix-exp (cdr next))) 23 | (op2 (car next)) 24 | (rest (cdr next))) 25 | (cons (diff-exp op1 op2) 26 | rest)))))))) 27 | 28 | (define make-prefix 29 | (lambda (prog) 30 | (car (make-prefix-exp prog)))) 31 | 32 | (equal?? (make-prefix '(1)) '(const-exp 1)) 33 | (equal?? (make-prefix '(- 1 2)) '(diff-exp (const-exp 1) (const-exp 2))) 34 | (equal?? (make-prefix'(- - 3 2 - 4 - 12 7)) 35 | '(diff-exp (diff-exp (const-exp 3) (const-exp 2)) (diff-exp (const-exp 4) (diff-exp (const-exp 12) (const-exp 7))))) 36 | 37 | ;;(make-prefix '(-)) -> error 38 | -------------------------------------------------------------------------------- /ch6/21.scm: -------------------------------------------------------------------------------- 1 | ;; Modify cps-of-call-exp so that the operands are evaluated 2 | ;; from left to right, followed by the operator. 3 | 4 | (load-relative "../libs/init.scm") 5 | (load-relative "./base/test.scm") 6 | (load-relative "./base/cps.scm") 7 | (load-relative "./base/data-structures.scm") 8 | (load-relative "./base/cps-cases.scm") 9 | (load-relative "./base/cps-lang.scm") 10 | (load-relative "./base/base-iterp.scm") 11 | 12 | 13 | (define last 14 | (lambda (lst) 15 | (if (null? (cdr lst)) 16 | (car lst) 17 | (last (cdr lst))))) 18 | 19 | (define remove-last-iter 20 | (lambda (lst cur) 21 | (if (null? (cdr lst)) 22 | cur 23 | (remove-last-iter (cdr lst) 24 | (append cur (list (car lst))))))) 25 | 26 | (define remove-last 27 | (lambda (lst) 28 | (remove-last-iter lst '()))) 29 | 30 | 31 | (define cps-of-call-exp 32 | (lambda (rator rands k-exp) 33 | (cps-of-exps (cons rands rator) 34 | (lambda (new-rands) 35 | (cps-call-exp 36 | (last new-rands) 37 | (append (remove-last new-rands) (list k-exp))))))) 38 | 39 | (run "(proc(x) x 3)") 40 | 41 | 42 | 43 | (run "(proc(x) -(x,1) 30)") 44 | 45 | (run-all) 46 | -------------------------------------------------------------------------------- /ch1/35-2.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | (load "31.scm") 3 | 4 | (define number-leaves 5 | (lambda (btree) 6 | (let ((n -1)) 7 | (define replace-leaf-with 8 | (lambda (btree) 9 | (cond ((leaf? btree) 10 | (set! n (+ n 1)) 11 | n) 12 | (else 13 | (interior-node (contents-of btree) 14 | (replace-leaf-with (lson btree)) 15 | (replace-leaf-with (rson btree))))))) 16 | (replace-leaf-with btree)))) 17 | 18 | (equal?? (number-leaves 19 | (interior-node 'foo 20 | (interior-node 'bar 21 | (leaf 26) 22 | (leaf 12)) 23 | (interior-node 'baz 24 | (leaf 11) 25 | (interior-node 'quux 26 | (leaf 117) 27 | (leaf 14))))) 28 | '(foo 29 | (bar 0 1) 30 | (baz 2 (quux 3 4)))) 31 | -------------------------------------------------------------------------------- /ch9/30.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;; interface summable 4 | ;; method int sum() 5 | 6 | ;; class sum_list extends object 7 | ;; implements summable 8 | ;; field summable first 9 | ;; field summable left 10 | ;; method void initialize(f : summable, l : summable) 11 | ;; begin 12 | ;; set first = f; set left = l 13 | ;; end 14 | ;; method int sum() +(send first sum(), send left sum()) 15 | 16 | ;; class leaf_node extends object 17 | ;; implements summable 18 | ;; field int value 19 | ;; method void initialize(v : int)set value = v 20 | ;; method int sum() value 21 | 22 | ;; class interior_node extends object 23 | ;; implements summable 24 | ;; field summable left 25 | ;; field summable right 26 | ;; method void initialize(l : summable, r : summable) 27 | ;; begin 28 | ;; set left = l; set right = r 29 | ;; end 30 | ;; method int sum() +(send left sum(), send right sum()) 31 | 32 | ;; class general_tree extends object 33 | ;; implements summable 34 | ;; field sum_list left 35 | ;; field sum_list right 36 | ;; method void initialize(l : sum_list, r : sum_list) 37 | ;; begin 38 | ;; set left = l; set right = r 39 | ;; end 40 | ;; method int sum + (send left sum(), send right sum()) 41 | -------------------------------------------------------------------------------- /ch8/20.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; finish module procedure, 3 | 4 | module sum-prod-maker 5 | interface 6 | ((ints : [opaque t 7 | zero : t 8 | => [plus 9 | succ : (t -> t) 10 | pred : (t -> t) 11 | is-zero : (t -> bool)]) 12 | => [plus : (from ints take t 13 | -> (from ints take t 14 | -> from ints take t)) 15 | 16 | times : (from ints take t 17 | -> (from ints take t 18 | -> from ints take t))]) 19 | body 20 | [plus = let ty = from ints take t 21 | in let z? = from ints take is-zero 22 | in let p = from ints take pred 23 | in let s = from ints take succ 24 | in letrec ty sum-proc (x: ty) = 25 | proc(y : ty) 26 | if z?(x) then y else 27 | ((sum-proc (p x)) (s y)) 28 | in sum-proc 29 | 30 | times = let ty = from ints take t 31 | in let z? = from ints take is-zero 32 | in let p = from ints take pred 33 | in let s = from ints take succ 34 | in letrec ty times-proc (x : ty) = 35 | proc(y : ty) 36 | if z?(p x) then y else 37 | ((times-proc (p x)) ((plus y) y))]) 38 | -------------------------------------------------------------------------------- /ch1/35.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define leaf (lambda (n) n)) 4 | (define leaf? number?) 5 | (define interior-node list) 6 | (define interior-node? list?) 7 | (define left cadr) 8 | (define right caddr) 9 | 10 | (define number-leaves 11 | (lambda (bt) 12 | (car (number-leaves-from bt 0)))) 13 | 14 | (define number-leaves-from 15 | (lambda (bt n) 16 | (cond 17 | ((null? bt) (list bt n)) 18 | ((interior-node? bt) 19 | (let* ([lt (number-leaves-from (left bt) n)] 20 | [rt (number-leaves-from (right bt) (cadr lt))]) 21 | (list (interior-node (car bt) (car lt) (car rt)) (cadr rt)))) 22 | ((leaf? bt) (list n (+ n 1)))))) 23 | 24 | (equal?? (number-leaves 25 | (interior-node 'foo 26 | (interior-node 'bar 27 | (leaf 26) 28 | (leaf 12)) 29 | (interior-node 'baz 30 | (leaf 11) 31 | (interior-node 'quux 32 | (leaf 117) 33 | (leaf 14))))) 34 | '(foo 35 | (bar 0 1) 36 | (baz 2 (quux 3 4)))) 37 | 38 | -------------------------------------------------------------------------------- /ch2/28.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define id? 4 | (lambda (symbol) 5 | (not (and (symbol? symbol) 6 | (eqv? symbol 'lambda))))) 7 | 8 | (define-datatype lc-expr lc-expr? 9 | (var-expr 10 | (var id?)) 11 | (lambda-expr 12 | (bound-var id?) 13 | (body lc-expr?)) 14 | (app-expr 15 | (rator lc-expr?) 16 | (rand lc-expr?))) 17 | 18 | (define unparse 19 | (lambda (exp) 20 | (cases lc-expr exp 21 | (var-expr (var) 22 | (symbol->string var)) 23 | (lambda-expr (bound-var body) 24 | (format "(lambda (~a) ~a)" bound-var (unparse body))) 25 | (app-expr (rator rand) 26 | (format "(~a ~a)" (unparse rator) (unparse rand)))))) 27 | 28 | 29 | (define expA (var-expr 'a)) 30 | (define expB (var-expr 'b)) 31 | (define app (app-expr expA expB)) 32 | (define lexp (lambda-expr 'a app)) 33 | (equal?? (unparse app) "(a b)") 34 | (equal?? (unparse lexp) "(lambda (a) (a b))") 35 | 36 | 37 | (define lexp 38 | (lambda-expr 'x 39 | (lambda-expr 'y 40 | (lambda-expr 'x 41 | (app-expr 42 | (lambda-expr 'x 43 | (app-expr (var-expr 'x) 44 | (var-expr 'y))) 45 | (var-expr 'x)))))) 46 | 47 | (equal?? (unparse lexp) "(lambda (x) (lambda (y) (lambda (x) ((lambda (x) (x y)) x))))") 48 | -------------------------------------------------------------------------------- /ch2/22.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | (define value? 5 | (lambda (v) 6 | #t)) 7 | 8 | (define-datatype stack stack? 9 | (empty-stack-record) 10 | (push-record 11 | (e value?) 12 | (s stack?)) 13 | (pop-record 14 | (s stack?))) 15 | 16 | (define empty-stack 17 | (lambda () 18 | (empty-stack-record))) 19 | 20 | (define push 21 | (lambda (e s) 22 | (push-record e s))) 23 | 24 | (define pop 25 | (lambda (st) 26 | (cases stack st 27 | (empty-stack-record () 28 | (error 'pop "Empty stack")) 29 | (push-record (e s) s) 30 | (pop-record (s) s)))) 31 | 32 | 33 | (define top 34 | (lambda (st) 35 | (cases stack st 36 | (empty-stack-record () 37 | (error 'top "Empty stack")) 38 | (push-record (e s) e) 39 | (pop-record (s) (top s))))) 40 | 41 | (define empty-stack? 42 | (lambda (st) 43 | (cases stack st 44 | (empty-stack-record () #t) 45 | (push-record (e s) #f) 46 | (pop-record (s) (empty-stack? s))))) 47 | 48 | (define e (empty-stack)) 49 | (define e (push 1 e)) 50 | (define e (push 2 e)) 51 | (define e (push 3 e)) 52 | 53 | (equal?? (top e) 3) 54 | (define e (pop e)) 55 | 56 | (equal?? (top e) 2) 57 | 58 | (define x (top e)) 59 | (equal?? x 2) 60 | 61 | (define e (pop e)) 62 | (define e (pop e)) 63 | (empty-stack? e) 64 | -------------------------------------------------------------------------------- /ch6/01.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | 3 | ;; without (set! pc fact/k) in fack/k and 4 | ;; without (set! pc apply-cont) in apply-cont 5 | ;; this program still work 6 | 7 | (define n 'uninitialized) 8 | (define cont 'uninitialized) 9 | (define val 'uninitialized) 10 | 11 | (define-datatype continuation continuation? 12 | (end-cont) 13 | (fact1-cont 14 | (n integer?) 15 | (cont continuation?))) 16 | 17 | (define fact 18 | (lambda (arg-n) 19 | (set! cont (end-cont)) 20 | (set! n arg-n) 21 | (set! pc fact/k) 22 | (trampoline!) 23 | val)) 24 | 25 | (define trampoline! 26 | (lambda () 27 | (if pc (begin 28 | (printf "now: ~a -> ~a\n" pc val) 29 | (pc) 30 | (trampoline!))))) 31 | 32 | (define fact/k 33 | (lambda () 34 | (if (zero? n) 35 | (begin 36 | (set! val 1) 37 | (set! pc apply-cont)) 38 | (begin 39 | (set! cont (fact1-cont n cont)) 40 | (set! n (- n 1)))))) 41 | 42 | 43 | (define apply-cont 44 | (lambda () 45 | (cases continuation cont 46 | (end-cont () 47 | (set! pc #f)) 48 | (fact1-cont (saved-n saved-cont) 49 | (set! cont saved-cont) 50 | (set! val (* val saved-n)))))) 51 | 52 | 53 | (fact 10) 54 | -------------------------------------------------------------------------------- /ch9/02.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/classes/test.scm") 3 | (load-relative "./base/classes/store.scm") 4 | (load-relative "./base/classes/data-structures.scm") 5 | (load-relative "./base/classes/environments.scm") 6 | (load-relative "./base/classes/lang.scm") 7 | (load-relative "./base/classes/interp.scm") 8 | (load-relative "./base/classes/classes.scm") 9 | (load-relative "./base/classes/class-cases.scm") 10 | 11 | ;;;(define debug? (make-parameter #t)) 12 | 13 | 14 | ;;a bug oddeven 15 | 16 | (run "class oddeven extends object 17 | method initialize () 1 18 | method even(n) 19 | if zero?(n) then 1 else send self odd(-(n, 1)) 20 | method odd(n) 21 | if zero?(n) then 0 else send self even(-(n, 1)) 22 | let o1 = new oddeven() 23 | in send o1 odd(13)") 24 | ;; => 1 25 | 26 | ;; extend even with a wrong buggy even 27 | (run " 28 | class oddeven extends object 29 | method initialize () 1 30 | method even(n) 31 | if zero?(n) then 1 else send self odd(-(n, 1)) 32 | method odd(n) 33 | if zero?(n) then 0 else send self even(-(n, 1)) 34 | 35 | class bug-oddeven extends oddeven 36 | method initialize () 1 37 | method even(n) 38 | if zero?(n) then 0 else send self odd(-(n, 1)) 39 | let o1 = new bug-oddeven() 40 | in send o1 odd(13)") 41 | ;; => 0 42 | 43 | (run-all) 44 | -------------------------------------------------------------------------------- /ch2/13.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; data definition: 4 | ;; Env = Var -> Schemeval 5 | 6 | ;; empty-env : () -> Env 7 | (define empty-env 8 | (lambda () 9 | (cons (lambda (search-var) 10 | (report-no-binding-found search-var)) 11 | (lambda () 12 | #t)))) 13 | 14 | 15 | ;; extend-env : Var * Schemeval * Env -> Env 16 | (define extend-env 17 | (lambda (saved-var saved-val saved-env) 18 | (cons (lambda (search-var) 19 | (if (eqv? search-var saved-var) 20 | saved-val 21 | (apply-env saved-env search-var))) 22 | (lambda () 23 | #f)))) 24 | 25 | ;; apply-env : Env * Var -> Schemeval 26 | (define apply-env 27 | (lambda (env search-var) 28 | ((car env) search-var))) 29 | 30 | (define empty-env? 31 | (lambda (env) 32 | ((cdr env)))) 33 | 34 | (define report-no-binding-found 35 | (lambda (search-var) 36 | (error 'apply-env "No binding for ~s" search-var))) 37 | 38 | (define report-invalid-env 39 | (lambda (env) 40 | (error 'apply-env "Bad environment: ~s" env))) 41 | 42 | (define e 43 | (extend-env 'd 6 44 | (extend-env 'y 8 45 | (extend-env 'x 7 46 | (extend-env 'y 14 47 | (empty-env)))))) 48 | 49 | (equal?? (apply-env e 'd) 6) 50 | (equal?? (apply-env e 'y) 8) 51 | (equal?? (apply-env e 'x) 7) 52 | 53 | (equal?? (empty-env? (empty-env)) #t) 54 | (equal?? (empty-env? e) #f) 55 | -------------------------------------------------------------------------------- /ch6/03.scm: -------------------------------------------------------------------------------- 1 | ;;rewrite each of these in continuation-passing style 2 | 3 | ;; 1. (lambda (x y) (p (+ 8 x) (q y))) 4 | ;; ==> 5 | (lambda (x y cont) 6 | (q y (lambda (val) 7 | (p (+ 8 x) val cont)))) 8 | 9 | ;;2. (lambda (x y u v) (+ 1 (f (g x y) (+ u v)))) 10 | ;; ==> 11 | (lambda (x y u v cont) 12 | (g x y (lambda (val) 13 | (f val (+ u v) (lambda (val2) 14 | (cont (+ 1 val2))))))) 15 | 16 | ;; 3. (+ 1 (f (g x y) (+ u (h v)))) 17 | ;; => 18 | (h v (lambda (val) 19 | (g x y (lambda (val2) 20 | (f val2 (+ u val) (lambda (val3) 21 | (cont (+ 1 val3)))))))) 22 | 23 | ;; 4. (zero? (if a (p x) (p y))) 24 | ;; => 25 | (p x (lambda (val) 26 | (p y (lambda (val2) 27 | ((lambda (val3) 28 | (cont (zero? val3))) 29 | (if a val val2)))))) 30 | 31 | ;; 5. (zero? (if (f a) (p x) (p y))) 32 | ;; => 33 | (f a (lambda (val) 34 | (p x (lambda (val3) 35 | (p y (lambda (val4) 36 | ((lambda (val5) 37 | (cont (zero? val5))) 38 | (if val val3 val4)))))))) 39 | 40 | ;; 6. (let ((x (let ((y 8)) (p y)))) x) 41 | ;; => 42 | ((let ((y 8)) 43 | (p y)) (lambda (val) 44 | (let ((x val)) 45 | (cont x)))) 46 | 47 | 48 | ;; 7. (let ((x (if a (p x) (p y)))) x) 49 | ;; => 50 | (p x (lambda (val) 51 | (p y (lambda (val2) 52 | ((lambda (val3) 53 | (let (x val3) 54 | (cont x))) 55 | (if a val val2)))))) 56 | -------------------------------------------------------------------------------- /base/chapter7/inferred/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | (provide init-env empty-env extend-env apply-env) 5 | 6 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 7 | 8 | ;; init-env : () -> environment 9 | 10 | ;; (init-env) builds an environment in which i is bound to the 11 | ;; expressed value 1, v is bound to the expressed value 5, and x is 12 | ;; bound to the expressed value 10. 13 | 14 | (define init-env 15 | (lambda () 16 | (extend-env 17 | 'i (num-val 1) 18 | (extend-env 19 | 'v (num-val 5) 20 | (extend-env 21 | 'x (num-val 10) 22 | (empty-env)))))) 23 | 24 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 25 | 26 | (define apply-env 27 | (lambda (env search-sym) 28 | (cases environment env 29 | (empty-env () 30 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 31 | (extend-env (bvar bval saved-env) 32 | (if (eqv? search-sym bvar) 33 | bval 34 | (apply-env saved-env search-sym))) 35 | (extend-env-rec (p-name b-var p-body saved-env) 36 | (if (eqv? search-sym p-name) 37 | (proc-val (procedure b-var p-body env)) 38 | (apply-env saved-env search-sym)))))) 39 | 40 | ) -------------------------------------------------------------------------------- /base/chapter7/checked/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | 5 | (provide init-env empty-env extend-env apply-env) 6 | 7 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 8 | 9 | ;; init-env : () -> environment 10 | 11 | ;; (init-env) builds an environment in which i is bound to the 12 | ;; expressed value 1, v is bound to the expressed value 5, and x is 13 | ;; bound to the expressed value 10. 14 | 15 | (define init-env 16 | (lambda () 17 | (extend-env 18 | 'i (num-val 1) 19 | (extend-env 20 | 'v (num-val 5) 21 | (extend-env 22 | 'x (num-val 10) 23 | (empty-env)))))) 24 | 25 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 26 | 27 | (define apply-env 28 | (lambda (env search-sym) 29 | (cases environment env 30 | (empty-env () 31 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 32 | (extend-env (bvar bval saved-env) 33 | (if (eqv? search-sym bvar) 34 | bval 35 | (apply-env saved-env search-sym))) 36 | (extend-env-rec (p-name b-var p-body saved-env) 37 | (if (eqv? search-sym p-name) 38 | (proc-val (procedure b-var p-body env)) 39 | (apply-env saved-env search-sym)))))) 40 | 41 | ) -------------------------------------------------------------------------------- /ch8/15.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/test.scm") 3 | (load-relative "./base/data-structures.scm") 4 | (load-relative "./base/type-structures.scm") 5 | (load-relative "./base/type-module.scm") 6 | (load-relative "./base/grammar.scm") 7 | (load-relative "./base/renaming.scm") 8 | (load-relative "./base/subtyping.scm") 9 | (load-relative "./base/expand-type.scm") 10 | (load-relative "./base/type-cases.scm") 11 | 12 | (define debug? (make-parameter #t)) 13 | 14 | (run "module tables 15 | interface 16 | [opaque table 17 | empty : table 18 | add-to-table : (int -> (int -> (table -> table))) 19 | lookup-in-table : (int -> (table -> int))] 20 | body 21 | [type table = (int -> int) 22 | empty = proc (x : int) x 23 | add-to-table = proc (x : int) 24 | proc (y : int) 25 | proc (t : table) 26 | proc (v : int) 27 | if zero?(- (v, x)) then y else (t v) 28 | lookup-in-table = proc(key : int) 29 | proc(t : table) 30 | (t key) 31 | ] 32 | let empty = from tables take empty 33 | in let add-binding = from tables take add-to-table 34 | in let lookup = from tables take lookup-in-table 35 | in let table1 = (((add-binding 3) 300) 36 | (((add-binding 4) 400) 37 | (((add-binding 3) 600) 38 | empty))) 39 | in -(((lookup 4) table1), 40 | ((lookup 3) table1))") 41 | -------------------------------------------------------------------------------- /ch2/29.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define id? 4 | (lambda (symbol) 5 | (not (and (symbol? symbol) 6 | (eqv? symbol 'lambda))))) 7 | 8 | (define list-of 9 | (lambda (pred) 10 | (lambda (val) 11 | (or (null? val) 12 | (and (pair? val) 13 | (pred (car val)) 14 | ((list-of pred) (cdr val))))))) 15 | 16 | ;;((list-of number?) '(1 2 3)) 17 | 18 | (define-datatype lc-expr lc-expr? 19 | (var-expr 20 | (var id?)) 21 | (lambda-expr 22 | (bound-vars (list-of id?)) 23 | (body lc-expr?)) 24 | (app-expr 25 | (rator lc-expr?) 26 | (rands (list-of lc-expr?)))) 27 | 28 | (define parse 29 | (lambda (exp) 30 | (cond 31 | ((eqv? exp 'lambda) 32 | (error 'parse "lambda is not a valid id")) 33 | ((symbol? exp) 34 | (var-expr exp)) 35 | ((and (pair? exp) 36 | (eqv? (car exp) 'lambda)) 37 | (lambda-expr (cadr exp) (parse (caddr exp)))) 38 | ((pair? exp) 39 | (app-expr (parse (car exp)) 40 | (map parse (cdr exp)))) 41 | (else 42 | (error 'parse "parse error"))))) 43 | 44 | 45 | (equal?? (parse 'a) '(var-expr a)) 46 | (equal?? (parse '(lambda (a) (+ a b))) 47 | '(lambda-expr (a) (app-expr (var-expr +) ((var-expr a) (var-expr b))))) 48 | (equal?? (parse '(+ a b c)) 49 | '(app-expr (var-expr +) ((var-expr a) (var-expr b) (var-expr c)))) 50 | 51 | (parse '(a b c)) 52 | (parse '(lambda b c)) 53 | -------------------------------------------------------------------------------- /base/chapter2/sec2.2-proc-rep.scm: -------------------------------------------------------------------------------- 1 | (module sec2.2-proc-rep (lib "eopl.ss" "eopl") 2 | 3 | ;; Simple procedural representation of environments 4 | ;; Page: 40 5 | 6 | (require "utils.scm") 7 | 8 | ;; data definition: 9 | ;; Env = Var -> Schemeval 10 | 11 | ;; empty-env : () -> Env 12 | (define empty-env 13 | (lambda () 14 | (lambda (search-var) 15 | (report-no-binding-found search-var)))) 16 | 17 | ;; extend-env : Var * Schemeval * Env -> Env 18 | (define extend-env 19 | (lambda (saved-var saved-val saved-env) 20 | (lambda (search-var) 21 | (if (eqv? search-var saved-var) 22 | saved-val 23 | (apply-env saved-env search-var))))) 24 | 25 | ;; apply-env : Env * Var -> Schemeval 26 | (define apply-env 27 | (lambda (env search-var) 28 | (env search-var))) 29 | 30 | (define report-no-binding-found 31 | (lambda (search-var) 32 | (eopl:error 'apply-env "No binding for ~s" search-var))) 33 | 34 | (define report-invalid-env 35 | (lambda (env) 36 | (eopl:error 'apply-env "Bad environment: ~s" env))) 37 | 38 | (define e 39 | (extend-env 'd 6 40 | (extend-env 'y 8 41 | (extend-env 'x 7 42 | (extend-env 'y 14 43 | (empty-env)))))) 44 | 45 | (equal?? (apply-env e 'd) 6) 46 | (equal?? (apply-env e 'y) 8) 47 | (equal?? (apply-env e 'x) 7) 48 | 49 | (report-unit-tests-completed 'apply-env) 50 | 51 | ) 52 | 53 | 54 | -------------------------------------------------------------------------------- /ch5/base/semaphores.scm: -------------------------------------------------------------------------------- 1 | ;; implements binary semaphores (mutexes). 2 | 3 | (define instrument-mutexes (make-parameter #f)) 4 | 5 | ;; new-mutex () -> Mutex 6 | ;; Page: 188 7 | (define new-mutex 8 | (lambda () 9 | (a-mutex 10 | (newref #f) 11 | (newref '())))) 12 | 13 | ;; wait-for-mutex : Mutex * Thread -> FinalAnswer 14 | ;; waits for mutex to be open, then closes it. 15 | ;; Page: 190 16 | (define wait-for-mutex 17 | (lambda (m th) 18 | (cases mutex m 19 | (a-mutex (ref-to-closed? ref-to-wait-queue) 20 | (cond 21 | ((deref ref-to-closed?) 22 | (setref! ref-to-wait-queue 23 | (enqueue (deref ref-to-wait-queue) th)) 24 | (run-next-thread)) 25 | (else 26 | (setref! ref-to-closed? #t) 27 | (th))))))) 28 | 29 | ;; signal-mutex : Mutex * Thread -> FinalAnswer 30 | ;; Page 190 31 | (define signal-mutex 32 | (lambda (m th) 33 | (cases mutex m 34 | (a-mutex (ref-to-closed? ref-to-wait-queue) 35 | (let ((closed? (deref ref-to-closed?)) 36 | (wait-queue (deref ref-to-wait-queue))) 37 | (if closed? 38 | (if (empty? wait-queue) 39 | (setref! ref-to-closed? #f) 40 | (dequeue wait-queue 41 | (lambda (first-waiting-th other-waiting-ths) 42 | (place-on-ready-queue! 43 | first-waiting-th) 44 | (setref! 45 | ref-to-wait-queue 46 | other-waiting-ths))))) 47 | (th)))))) 48 | -------------------------------------------------------------------------------- /ch5/base/semaphores-data-structure.scm: -------------------------------------------------------------------------------- 1 | ;; implements binary semaphores (mutexes). 2 | 3 | (define instrument-mutexes (make-parameter #f)) 4 | 5 | ;; new-mutex () -> Mutex 6 | (define new-mutex 7 | (lambda () 8 | (a-mutex 9 | (newref #f) 10 | (newref '())))) 11 | 12 | ;; wait queue, initially empty 13 | ;; wait-for-mutex : Mutex * Thread -> FinalAnswer 14 | ;; waits for mutex to be open, then closes it. 15 | ;; Page: 190 16 | (define wait-for-mutex 17 | (lambda (m th) 18 | (cases mutex m 19 | (a-mutex (ref-to-closed? ref-to-wait-queue) 20 | (cond 21 | ((deref ref-to-closed?) 22 | (setref! ref-to-wait-queue 23 | (enqueue (deref ref-to-wait-queue) th)) 24 | (run-next-thread)) 25 | (else 26 | (setref! ref-to-closed? #t) 27 | th)))))) 28 | 29 | ;; signal-mutex : Mutex * Thread -> FinalAnswer 30 | ;; Page 190 31 | (define signal-mutex 32 | (lambda (m th) 33 | (cases mutex m 34 | (a-mutex (ref-to-closed? ref-to-wait-queue) 35 | (let ((closed? (deref ref-to-closed?)) 36 | (wait-queue (deref ref-to-wait-queue))) 37 | (if closed? 38 | (if (empty? wait-queue) 39 | (setref! ref-to-closed? #f) 40 | (dequeue wait-queue 41 | (lambda (first-waiting-th other-waiting-ths) 42 | (place-on-ready-queue! 43 | first-waiting-th) 44 | (setref! 45 | ref-to-wait-queue 46 | other-waiting-ths))))) 47 | th))))) 48 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/environments.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; builds environment interface, using data structures defined in 3 | ;; data-structures.scm. 4 | 5 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 6 | 7 | ;; init-env : () -> Env 8 | ;; usage: (init-env) = [i=1, v=5, x=10] 9 | ;; (init-env) builds an environment in which i is bound to the 10 | ;; expressed value 1, v is bound to the expressed value 5, and x is 11 | ;; bound to the expressed value 10. 12 | ;; Page: 69 13 | 14 | (define init-env 15 | (lambda () 16 | (extend-env 17 | 'i (num-val 1) 18 | (extend-env 19 | 'v (num-val 5) 20 | (extend-env 21 | 'x (num-val 10) 22 | (empty-env)))))) 23 | 24 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 25 | 26 | (define empty-env 27 | (lambda () 28 | (empty-env-record))) 29 | 30 | (define empty-env? 31 | (lambda (x) 32 | (empty-env-record? x))) 33 | 34 | (define extend-env 35 | (lambda (sym val old-env) 36 | (extended-env-record sym val old-env))) 37 | 38 | (define apply-env 39 | (lambda (env search-sym) 40 | (if (empty-env? env) 41 | (eopl:error 'apply-env "No binding for ~s" search-sym) 42 | (let ((sym (extended-env-record->sym env)) 43 | (val (extended-env-record->val env)) 44 | (old-env (extended-env-record->old-env env))) 45 | (if (eqv? search-sym sym) 46 | val 47 | (apply-env old-env search-sym)))))) 48 | -------------------------------------------------------------------------------- /ch2/18.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define (number->sequence node) 4 | `(,node () ())) 5 | 6 | (define (current-element lst) 7 | (car lst)) 8 | 9 | (define (at-left-end? lst) 10 | (null? (cadr lst))) 11 | 12 | (define (at-right-end? lst) 13 | (null? (caddr lst))) 14 | 15 | (define (move-to-left lst) 16 | (if (at-left-end? lst) 17 | (report-at-the-end-of-left) 18 | (list (caadr lst) (cdadr lst) (cons (car lst) (caddr lst))))) 19 | 20 | (define (move-to-right lst) 21 | (if (at-right-end? lst) 22 | (report-at-the-end-of-right) 23 | (list (caaddr lst) (cons (car lst) (cadr lst)) (cdaddr lst)))) 24 | 25 | (define (report-at-the-end-of-left) 26 | (error 'move-to-left "Already at the end of the left.")) 27 | 28 | (define (report-at-the-end-of-right) 29 | (error 'move-to-right "Already at the end of the right.")) 30 | 31 | (define (insert-to-left node lst) 32 | (list (car lst) (cons node (cadr lst)) (caddr lst))) 33 | 34 | (define (insert-to-right node lst) 35 | (list (car lst) (cadr lst) (cons node(caddr lst)))) 36 | 37 | (equal?? 6 (current-element '(6 (5 4 3 2 1) (7 8 9)))) 38 | (equal?? '(5 (4 3 2 1) (6 7 8 9)) (move-to-left '(6 (5 4 3 2 1) (7 8 9)))) 39 | (equal?? '(7 (6 5 4 3 2 1) (8 9)) (move-to-right '(6 (5 4 3 2 1) (7 8 9)))) 40 | (equal?? '(6 (13 5 4 3 2 1) (7 8 9)) (insert-to-left 13 '(6 (5 4 3 2 1) (7 8 9)))) 41 | (equal?? '(6 (5 4 3 2 1) (13 7 8 9)) (insert-to-right 13 '(6 (5 4 3 2 1) (7 8 9)))) 42 | 43 | (equal?? '(6 (5 4 3 2 1) (7 8 9)) (move-to-right (move-to-left '(6 (5 4 3 2 1) (7 8 9))))) -------------------------------------------------------------------------------- /ch8/21.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; based on 20.scm 3 | 4 | module sum-prod-maker 5 | interface 6 | ((ints : [opaque t 7 | zero : t 8 | => [plus 9 | succ : (t -> t) 10 | pred : (t -> t) 11 | is-zero : (t -> bool)]) 12 | => [plus : (from ints take t 13 | -> (from ints take t 14 | -> from ints take t)) 15 | 16 | times : (from ints take t 17 | -> (from ints take t 18 | -> from ints take t)) 19 | k-th : ( from ints take t -> (from ints take t))]) 20 | 21 | body 22 | [ 23 | plus = let ty = from ints take t 24 | in let z? = from ints take is-zero 25 | in let p = from ints take pred 26 | in let s = from ints take succ 27 | in letrec ty sum-proc (x: ty) = 28 | proc(y : ty) 29 | if z?(x) then y else 30 | ((sum-proc (p x)) (s y)) 31 | in sum-proc 32 | 33 | times = let ty = from ints take t 34 | in let z? = from ints take is-zero 35 | in let p = from ints take pred 36 | in let s = from ints take succ 37 | in letrec ty times-proc (x : ty) = 38 | proc(y : ty) 39 | if z?(p x) then y else 40 | ((times-proc (p x)) ((plus y) y)) 41 | k-th = let ty = from ints take t 42 | in let z = from ints take zero 43 | in let s = from ints take succ 44 | in letrec ty k-th (x : ty) = ((times (succ (succ z))) x) 45 | int k-th] 46 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/lang.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 2 | 3 | (define the-lexical-spec 4 | '((whitespace (whitespace) skip) 5 | (comment ("%" (arbno (not #\newline))) skip) 6 | (identifier 7 | (letter (arbno (or letter digit "_" "-" "?"))) 8 | symbol) 9 | (number (digit (arbno digit)) number) 10 | (number ("-" digit (arbno digit)) number) 11 | )) 12 | 13 | (define the-grammar 14 | '((program (expression) a-program) 15 | 16 | (expression (number) const-exp) 17 | (expression 18 | ("-" "(" expression "," expression ")") 19 | diff-exp) 20 | 21 | (expression 22 | ("zero?" "(" expression ")") 23 | zero?-exp) 24 | 25 | (expression 26 | ("if" expression "then" expression "else" expression) 27 | if-exp) 28 | 29 | (expression (identifier) var-exp) 30 | 31 | (expression 32 | ("let" identifier "=" expression "in" expression) 33 | let-exp) 34 | 35 | )) 36 | 37 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 38 | 39 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 40 | 41 | (define show-the-datatypes 42 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 43 | 44 | (define scan&parse 45 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 46 | 47 | (define just-scan 48 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 49 | -------------------------------------------------------------------------------- /base/chapter8/simplemodules/subtyping.scm: -------------------------------------------------------------------------------- 1 | (module subtyping (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") 4 | 5 | (provide <:-iface) 6 | 7 | ;; <:-iface : Iface * Iface * Tenv -> Bool 8 | ;; Page: 289 9 | (define <:-iface 10 | (lambda (iface1 iface2 tenv) 11 | (cases interface iface1 12 | (simple-iface (decls1) 13 | (cases interface iface2 14 | (simple-iface (decls2) 15 | (<:-decls decls1 decls2 tenv))))))) 16 | 17 | ;; <:-decls : Listof(Decl) * Listof(Decl) * Tenv -> Bool 18 | ;; Page: 289 19 | ;; 20 | ;; s1 <: s2 iff s1 has at least as much stuff as s2, and in the same 21 | ;; order. We walk down s1 until we find a declaration that declares 22 | ;; the same name as the first component of s2. If we run off the 23 | ;; end of s1, then we fail. As we walk down s1, we record any type 24 | ;; bindings in the tenv 25 | ;; 26 | (define <:-decls 27 | (lambda (decls1 decls2 tenv) 28 | (cond 29 | ((null? decls2) #t) 30 | ((null? decls1) #f) 31 | (else 32 | (let ((name1 (decl->name (car decls1))) 33 | (name2 (decl->name (car decls2)))) 34 | (if (eqv? name1 name2) 35 | (and 36 | (equal? 37 | (decl->type (car decls1)) 38 | (decl->type (car decls2))) 39 | (<:-decls (cdr decls1) (cdr decls2) tenv)) 40 | (<:-decls (cdr decls1) decls2 tenv))))))) 41 | 42 | ) -------------------------------------------------------------------------------- /ch6/20.scm: -------------------------------------------------------------------------------- 1 | ;; Our procedure cps-of-exps causes subexpressions to be evaluated from 2 | ;; left to right. Modify cps-of-exps so that subexpressions are evaluated 3 | ;; from right to left. 4 | 5 | (load-relative "../libs/init.scm") 6 | (load-relative "./base/test.scm") 7 | (load-relative "./base/cps.scm") 8 | (load-relative "./base/data-structures.scm") 9 | (load-relative "./base/cps-cases.scm") 10 | (load-relative "./base/cps-lang.scm") 11 | (load-relative "./base/base-iterp.scm") 12 | 13 | 14 | ;; New stuff, return the last index which pred is succeed 15 | (define last-index 16 | (lambda (pred lst) 17 | (let ((res #f)) 18 | (begin 19 | (do ((i (- (length lst) 1) 20 | (- i 1))) 21 | ((= i -1)) 22 | (if (pred (list-ref lst i)) 23 | (set! res i)))) 24 | res))) 25 | 26 | 27 | ;; cps-of-exps : Listof(InpExp) * (Listof(InpExp) -> TfExp) 28 | ;; -> TfExp 29 | (define cps-of-exps 30 | (lambda (exps builder) 31 | (let cps-of-rest ((exps exps)) 32 | (let ((pos (last-index 33 | (lambda (exp) 34 | (not (inp-exp-simple? exp))) 35 | exps))) 36 | (if (not pos) 37 | (builder (map cps-of-simple-exp exps)) 38 | (let ((var (fresh-identifier 'var))) 39 | (cps-of-exp 40 | (list-ref exps pos) 41 | (cps-proc-exp (list var) 42 | (cps-of-rest 43 | (list-set exps pos (var-exp var))))))))))) 44 | 45 | 46 | (run-all) 47 | -------------------------------------------------------------------------------- /ch2/10.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | (define empty-env 5 | (lambda() '())) 6 | 7 | (define extend-env 8 | (lambda (var val env) 9 | (cons (cons var val) 10 | env))) 11 | 12 | 13 | (define extend-env* 14 | (lambda (var-list val-list env) 15 | (if (null? var-list) 16 | env 17 | (let ((var (car var-list)) 18 | (val (car val-list))) 19 | (extend-env* (cdr var-list) 20 | (cdr val-list) 21 | (extend-env var val env)))))) 22 | (define apply-env 23 | (lambda (env search-var) 24 | (cond 25 | ((null? env) 26 | (report-no-binding-found search-var)) 27 | ((eqv? (caar env) search-var) 28 | (cdr (car env))) 29 | (else 30 | (apply-env (cdr env) search-var))))) 31 | 32 | (define report-no-binding-found 33 | (lambda (search-var) 34 | (error 'apply-env "No binding for: " search-var))) 35 | 36 | 37 | (define has-binding? 38 | (lambda (env var) 39 | (cond 40 | ((null? env) #f) 41 | ((eqv? (caar env) var) #t) 42 | (else 43 | (has-binding? (cdr env) var))))) 44 | 45 | 46 | (define e 47 | (extend-env 'd 6 48 | (extend-env 'y 8 49 | (extend-env 'x 7 50 | (extend-env 'y 14 51 | (empty-env)))))) 52 | 53 | (equal?? (has-binding? e 'd) #t) 54 | (equal?? (has-binding? e 'y) #t) 55 | (equal?? (has-binding? e 'x) #t) 56 | (equal?? (has-binding? e 'z) #f) 57 | 58 | 59 | (equal?? (has-binding? (extend-env* '(A) '(1) e) 'A) #t) 60 | (equal?? (has-binding? (extend-env* '(A B C) '(1 2 3) e) 'C) #t) 61 | -------------------------------------------------------------------------------- /ch2/19.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define (number->bintree node) 4 | `(,node () ())) 5 | 6 | (define (current-element lst) 7 | (car lst)) 8 | 9 | (define (move-to-left-son bintree) 10 | (cadr bintree)) 11 | 12 | (define (move-to-right-son bintree) 13 | (caddr bintree)) 14 | 15 | (define at-leaf? null?) 16 | 17 | (define (as-left-branch left bintree) 18 | (list (car bintree) left (move-to-right-son bintree))) 19 | 20 | (define (as-right-branch right bintree) 21 | (list (car bintree) (move-to-left-son bintree) right)) 22 | 23 | (define (insert-to-left node bintree) 24 | (cond ((at-leaf? bintree) #f) 25 | ((pair? (move-to-left-son bintree)) 26 | (list (car bintree) (as-left-branch (move-to-left-son bintree) (number->bintree node)) (caddr bintree))) 27 | (else (list (car bintree) (number->bintree node) (caddr bintree))))) 28 | 29 | (define (insert-to-right node bintree) 30 | (cond ((at-leaf? bintree) #f) 31 | ((pair? (move-to-right-son bintree)) 32 | (list (car bintree) (cadr bintree) (as-right-branch (move-to-right-son bintree) (number->bintree node)))) 33 | (else (list (car bintree) (cadr bintree) (number->bintree node))))) 34 | 35 | (equal?? '(13 () ()) (number->bintree 13)) 36 | (define t1 (insert-to-right 14 37 | (insert-to-left 12 38 | (number->bintree 13)))) 39 | 40 | (equal?? '(12 () ()) (move-to-left-son t1)) 41 | (equal?? 12 (current-element (move-to-left-son t1))) 42 | (equal?? #t (at-leaf? (move-to-right-son (move-to-left-son t1)))) 43 | (equal?? (insert-to-left 15 t1) '(13 (15 (12 () ()) ()) (14 () ()))) 44 | -------------------------------------------------------------------------------- /base/chapter3/letrec-lang/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | ;; builds environment interface, using data structures defined in 4 | ;; data-structures.scm. 5 | 6 | (require "data-structures.scm") 7 | 8 | (provide init-env empty-env extend-env apply-env) 9 | 10 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 11 | 12 | ;; init-env : () -> Env 13 | ;; usage: (init-env) = [i=1, v=5, x=10] 14 | ;; (init-env) builds an environment in which i is bound to the 15 | ;; expressed value 1, v is bound to the expressed value 5, and x is 16 | ;; bound to the expressed value 10. 17 | ;; Page: 69 18 | 19 | (define init-env 20 | (lambda () 21 | (extend-env 22 | 'i (num-val 1) 23 | (extend-env 24 | 'v (num-val 5) 25 | (extend-env 26 | 'x (num-val 10) 27 | (empty-env)))))) 28 | 29 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 30 | 31 | ;; Page: 86 32 | (define apply-env 33 | (lambda (env search-sym) 34 | (cases environment env 35 | (empty-env () 36 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 37 | (extend-env (var val saved-env) 38 | (if (eqv? search-sym var) 39 | val 40 | (apply-env saved-env search-sym))) 41 | (extend-env-rec (p-name b-var p-body saved-env) 42 | (if (eqv? search-sym p-name) 43 | (proc-val (procedure b-var p-body env)) 44 | (apply-env saved-env search-sym)))))) 45 | 46 | ) -------------------------------------------------------------------------------- /base/chapter5/letrec-lang/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | ;; builds environment interface, using data structures defined in 4 | ;; data-structures.scm. 5 | 6 | (require "data-structures.scm") 7 | 8 | (provide init-env empty-env extend-env apply-env) 9 | 10 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 11 | 12 | ;; init-env : () -> Env 13 | ;; usage: (init-env) = [i=1, v=5, x=10] 14 | ;; (init-env) builds an environment in which i is bound to the 15 | ;; expressed value 1, v is bound to the expressed value 5, and x is 16 | ;; bound to the expressed value 10. 17 | ;; Page: 69 18 | 19 | (define init-env 20 | (lambda () 21 | (extend-env 22 | 'i (num-val 1) 23 | (extend-env 24 | 'v (num-val 5) 25 | (extend-env 26 | 'x (num-val 10) 27 | (empty-env)))))) 28 | 29 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 30 | 31 | ;; Page: 86 32 | (define apply-env 33 | (lambda (env search-sym) 34 | (cases environment env 35 | (empty-env () 36 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 37 | (extend-env (var val saved-env) 38 | (if (eqv? search-sym var) 39 | val 40 | (apply-env saved-env search-sym))) 41 | (extend-env-rec (p-name b-var p-body saved-env) 42 | (if (eqv? search-sym p-name) 43 | (proc-val (procedure b-var p-body env)) 44 | (apply-env saved-env search-sym)))))) 45 | 46 | ) -------------------------------------------------------------------------------- /ch5/base/scheduler.scm: -------------------------------------------------------------------------------- 1 | (define the-ready-queue 'uninitialized) 2 | (define the-final-answer 'uninitialized) 3 | 4 | (define the-max-time-slice 'uninitialized) 5 | (define the-time-remaining 'uninitialized) 6 | 7 | ;; initialize-scheduler! : Int -> Unspecified 8 | (define initialize-scheduler! 9 | (lambda (ticks) 10 | (set! the-ready-queue (empty-queue)) 11 | (set! the-final-answer 'uninitialized) 12 | (set! the-max-time-slice ticks) 13 | (set! the-time-remaining the-max-time-slice) 14 | )) 15 | 16 | ;;;;;;;;;;;;;;;; the final answer ;;;;;;;;;;;;;;;; 17 | 18 | ;; place-on-ready-queue! : Thread -> Unspecified 19 | (define place-on-ready-queue! 20 | (lambda (th) 21 | (set! the-ready-queue 22 | (enqueue the-ready-queue th)))) 23 | 24 | ;; run-next-thread : () -> FinalAnswer 25 | (define run-next-thread 26 | (lambda () 27 | (if (empty? the-ready-queue) 28 | the-final-answer 29 | (dequeue the-ready-queue 30 | (lambda (first-ready-thread other-ready-threads) 31 | (set! the-ready-queue other-ready-threads) 32 | (set! the-time-remaining the-max-time-slice) 33 | (first-ready-thread) 34 | ))))) 35 | 36 | ;; set-final-answer! : ExpVal -> Unspecified 37 | (define set-final-answer! 38 | (lambda (val) 39 | (set! the-final-answer val))) 40 | 41 | ;; time-expired? : () -> Bool 42 | (define time-expired? 43 | (lambda () 44 | (zero? the-time-remaining))) 45 | 46 | ;; decrement-timer! : () -> Unspecified 47 | (define decrement-timer! 48 | (lambda () 49 | (set! the-time-remaining (- the-time-remaining 1)))) 50 | -------------------------------------------------------------------------------- /ch6/06.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; How many different evaluation orders are possible for the procedure 3 | ;; calls in (lambda (x y) (+ (f (g x)) (h (j y))))? For each evaluation 4 | ;; order, write a CPS expression that calls the procedures in that order. 5 | 6 | ;; 4! ? for function f, g, h, j. 7 | 8 | (lambda (x y) 9 | (+ (f (g x)) 10 | (h (j y)))) 11 | 12 | ;; g -> j -> f -> h -> + 13 | (lambda (x y cont) 14 | (g x (lambda (val) 15 | (j y (lambda (val2) 16 | (f val (lambda (val3) 17 | (h val2 (lambda (val4) 18 | (cont (+ val3 val4))))))))))) 19 | 20 | ;; j -> g -> f -> h 21 | (lambda (x y cont) 22 | (j y (lambda (val) 23 | (g x (lambda (val2) 24 | (f val2 (lambda (val3) 25 | (h val (lambda (val4) 26 | (cont (+ val3 val4))))))))))) 27 | 28 | ;; g -> j -> h -> f 29 | (lambda (x y cont) 30 | (g x (lambda (val) 31 | (j y (lambda (val2) 32 | (h val2 (lambda (val3) 33 | (f val (lambda (val4) 34 | (cont (+ val4 val3))))))))))) 35 | 36 | ;; j -> g -> h -> f 37 | (lambda (x y cont) 38 | (j y (lambda (val) 39 | (g x (lambda (val2) 40 | (h val (lambda (val3) 41 | (f val2 (lambda (val4) 42 | (cont (+ val3 val4))))))))))) 43 | 44 | ;; g -> f -> j -> h 45 | (lambda (x y cont) 46 | (g x (lambda (val) 47 | (f val (lambda (val2) 48 | (j y (lambda (val3) 49 | (h val3 (lambda (val4) 50 | (cont (+ val2 val4))))))))))) 51 | 52 | ;; j -> h -> g -> f 53 | (lambda (x y cont) 54 | (j y (lambda (val) 55 | (h val (lambda (val2) 56 | (g x (lambda (val3) 57 | (f val3 (lambda (val4) 58 | (cont (+ val4 val2))))))))))) 59 | -------------------------------------------------------------------------------- /base/chapter4/mutable-pairs/pairval1.scm: -------------------------------------------------------------------------------- 1 | (module pairval1 (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") 5 | 6 | (provide (all-defined)) 7 | 8 | ;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;; 9 | 10 | ;; represent a mutable pair as two references. 11 | 12 | ;; Page: 124 13 | (define-datatype mutpair mutpair? 14 | (a-pair 15 | (left-loc reference?) 16 | (right-loc reference?))) 17 | 18 | ;; make-pair : ExpVal * ExpVal -> MutPair 19 | ;; Page: 124 20 | (define make-pair 21 | (lambda (val1 val2) 22 | (a-pair 23 | (newref val1) 24 | (newref val2)))) 25 | 26 | ;; left : MutPair -> ExpVal 27 | ;; Page: 125 28 | (define left 29 | (lambda (p) 30 | (cases mutpair p 31 | (a-pair (left-loc right-loc) 32 | (deref left-loc))))) 33 | 34 | ;; right : MutPair -> ExpVal 35 | ;; Page: 125 36 | (define right 37 | (lambda (p) 38 | (cases mutpair p 39 | (a-pair (left-loc right-loc) 40 | (deref right-loc))))) 41 | 42 | ;; setleft : MutPair * ExpVal -> Unspecified 43 | ;; Page: 125 44 | (define setleft 45 | (lambda (p val) 46 | (cases mutpair p 47 | (a-pair (left-loc right-loc) 48 | (setref! left-loc val))))) 49 | 50 | ;; setright : MutPair * ExpVal -> Unspecified 51 | ;; Page: 125 52 | (define setright 53 | (lambda (p val) 54 | (cases mutpair p 55 | (a-pair (left-loc right-loc) 56 | (setref! right-loc val))))) 57 | 58 | ) 59 | -------------------------------------------------------------------------------- /base/chapter4/call-by-need/pairval1.scm: -------------------------------------------------------------------------------- 1 | (module pairval1 (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") 5 | 6 | (provide (all-defined)) 7 | 8 | ;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;; 9 | 10 | ;; represent a mutable pair as two references. 11 | 12 | ;; Page: 124 13 | (define-datatype mutpair mutpair? 14 | (a-pair 15 | (left-loc reference?) 16 | (right-loc reference?))) 17 | 18 | ;; make-pair : ExpVal * ExpVal -> MutPair 19 | ;; Page: 124 20 | (define make-pair 21 | (lambda (val1 val2) 22 | (a-pair 23 | (newref val1) 24 | (newref val2)))) 25 | 26 | ;; left : MutPair -> ExpVal 27 | ;; Page: 125 28 | (define left 29 | (lambda (p) 30 | (cases mutpair p 31 | (a-pair (left-loc right-loc) 32 | (deref left-loc))))) 33 | 34 | ;; right : MutPair -> ExpVal 35 | ;; Page: 125 36 | (define right 37 | (lambda (p) 38 | (cases mutpair p 39 | (a-pair (left-loc right-loc) 40 | (deref right-loc))))) 41 | 42 | ;; setleft : MutPair * ExpVal -> Unspecified 43 | ;; Page: 125 44 | (define setleft 45 | (lambda (p val) 46 | (cases mutpair p 47 | (a-pair (left-loc right-loc) 48 | (setref! left-loc val))))) 49 | 50 | ;; setright : MutPair * ExpVal -> Unspecified 51 | ;; Page: 125 52 | (define setright 53 | (lambda (p val) 54 | (cases mutpair p 55 | (a-pair (left-loc right-loc) 56 | (setref! right-loc val))))) 57 | 58 | ) 59 | -------------------------------------------------------------------------------- /base/chapter4/call-by-reference/pairval1.scm: -------------------------------------------------------------------------------- 1 | (module pairval1 (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") 5 | 6 | (provide (all-defined)) 7 | 8 | ;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;; 9 | 10 | ;; represent a mutable pair as two references. 11 | 12 | ;; Page: 124 13 | (define-datatype mutpair mutpair? 14 | (a-pair 15 | (left-loc reference?) 16 | (right-loc reference?))) 17 | 18 | ;; make-pair : ExpVal * ExpVal -> MutPair 19 | ;; Page: 124 20 | (define make-pair 21 | (lambda (val1 val2) 22 | (a-pair 23 | (newref val1) 24 | (newref val2)))) 25 | 26 | ;; left : MutPair -> ExpVal 27 | ;; Page: 125 28 | (define left 29 | (lambda (p) 30 | (cases mutpair p 31 | (a-pair (left-loc right-loc) 32 | (deref left-loc))))) 33 | 34 | ;; right : MutPair -> ExpVal 35 | ;; Page: 125 36 | (define right 37 | (lambda (p) 38 | (cases mutpair p 39 | (a-pair (left-loc right-loc) 40 | (deref right-loc))))) 41 | 42 | ;; setleft : MutPair * ExpVal -> Unspecified 43 | ;; Page: 125 44 | (define setleft 45 | (lambda (p val) 46 | (cases mutpair p 47 | (a-pair (left-loc right-loc) 48 | (setref! left-loc val))))) 49 | 50 | ;; setright : MutPair * ExpVal -> Unspecified 51 | ;; Page: 125 52 | (define setright 53 | (lambda (p val) 54 | (cases mutpair p 55 | (a-pair (left-loc right-loc) 56 | (setref! right-loc val))))) 57 | 58 | ) 59 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/top.scm: -------------------------------------------------------------------------------- 1 | ;; here are some other things that could be provided: 2 | 3 | ;; (provide (all-defined)) 4 | ;; (provide (all-from "interp.scm")) 5 | ;; (provide (all-from "lang.scm")) 6 | 7 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 8 | 9 | ;; run : String -> ExpVal 10 | ;; Page: 71 11 | (define run 12 | (lambda (string) 13 | (value-of-program (scan&parse string)))) 14 | 15 | ;; run-all : () -> unspecified 16 | 17 | ;; runs all the tests in test-list, comparing the results with 18 | ;; equal-answer? 19 | 20 | (define run-all 21 | (lambda () 22 | (run-tests! run equal-answer? test-list))) 23 | 24 | (define equal-answer? 25 | (lambda (ans correct-ans) 26 | (equal? ans (sloppy->expval correct-ans)))) 27 | 28 | (define sloppy->expval 29 | (lambda (sloppy-val) 30 | (cond 31 | ((number? sloppy-val) (num-val sloppy-val)) 32 | ((boolean? sloppy-val) (bool-val sloppy-val)) 33 | (else 34 | (eopl:error 'sloppy->expval 35 | "Can't convert sloppy value to expval: ~s" 36 | sloppy-val))))) 37 | 38 | ;; run-one : symbol -> expval 39 | 40 | ;; (run-one sym) runs the test whose name is sym 41 | 42 | (define run-one 43 | (lambda (test-name) 44 | (let ((the-test (assoc test-name test-list))) 45 | (cond 46 | ((assoc test-name test-list) 47 | => (lambda (test) 48 | (run (cadr test)))) 49 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 50 | 51 | ;; (run-all) 52 | -------------------------------------------------------------------------------- /ch4/09.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; implement store using vector in Scheme 3 | ;; we have constant time for setref!, 4 | ;; but we have linear time for newref. 5 | 6 | (define instrument-newref (make-parameter #f)) 7 | 8 | (define the-store 'uninitialized-store) 9 | 10 | (define empty-store 11 | (lambda() 12 | (make-vector 0))) 13 | 14 | (define initialize-store! 15 | (lambda() 16 | (set! the-store (empty-store)))) 17 | 18 | (define get-store 19 | (lambda() 20 | (the-store))) 21 | 22 | (define store? 23 | (lambda (s) 24 | (cond ((eqv? s 'uninitialized-store) #t) 25 | ((vector? s) #t) 26 | (else 27 | #f)))) 28 | 29 | (define reference? 30 | (lambda(x) 31 | (integer? x))) 32 | 33 | ;;cost linear time 34 | (define vector-enlarge 35 | (lambda(store) 36 | (let* ((length (vector-length store)) 37 | (new-store (make-vector (+ length 1)))) 38 | (do ((i 0 (+ i 1))) 39 | ((= i length)) 40 | (vector-set! new-store i 41 | (vector-ref store i))) 42 | new-store))) 43 | 44 | (define newref 45 | (lambda (val) 46 | (let* ((next-ref (vector-length the-store)) 47 | (new-store (vector-enlarge the-store))) 48 | (vector-set! new-store next-ref val) 49 | (set! the-store new-store) 50 | (if (instrument-newref) 51 | (printf 52 | "newref: allocating location ~s with initial contents ~s~%" 53 | next-ref val)) 54 | next-ref))) 55 | 56 | 57 | (define deref 58 | (lambda (ref) 59 | (vector-ref the-store ref))) 60 | 61 | (define setref! 62 | (lambda (ref val) 63 | (vector-set! the-store ref val))) 64 | 65 | (define get-store-as-list 66 | (lambda() 67 | (vector->list the-store))) 68 | -------------------------------------------------------------------------------- /ch2/30.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define identifier? symbol?) 4 | 5 | (define-datatype lc-expr lc-expr? 6 | (var-expr 7 | (var identifier?)) 8 | (lambda-expr 9 | (bound-var identifier?) 10 | (body lc-expr?)) 11 | (app-expr 12 | (rator lc-expr?) 13 | (rand lc-expr?))) 14 | 15 | ;; parse-expression : Schemeval -> Lcexp 16 | ;; some fix on parse-expression on page 53 17 | (define parse-expression 18 | (lambda (datum) 19 | (cond 20 | ((symbol? datum) 21 | (when (eqv? datum 'lambda) 22 | (error 'parse "lambda is not valid symbol")) 23 | (var-expr datum)) 24 | ((pair? datum) 25 | (if (eqv? (car datum) 'lambda) 26 | (if (not (= (length datum) 3)) 27 | (error 'parse "lambda requires args and body") 28 | (if (not (list? (cadr datum))) 29 | (error 'parse "lamdba's args should be a list") 30 | (if (not (= (length (cadr datum)) 1 )) 31 | (error 'parse "lamdba's args should contains only one arg") 32 | (lambda-expr (car (cadr datum)) 33 | (parse-expression (caddr datum)))))) 34 | (if (not (= (length datum) 2)) 35 | (error 'parse "app-expr contains only rator and rand") 36 | (app-expr 37 | (parse-expression (car datum)) 38 | (parse-expression (cadr datum)))))) 39 | (else 40 | (error 'parse "error for ~s" datum))))) 41 | 42 | ;;(parse-expression 'lambda) -> error 43 | ;;(parse-expression '(a b c)) -> error 44 | (equal?? (parse-expression 'a) '(var-expr a)) 45 | (equal?? (parse-expression '(a b)) '(app-expr (var-expr a) (var-expr b))) 46 | (equal?? (parse-expression '(lambda (a) (a b))) '(lambda-expr a (app-expr (var-expr a) (var-expr b)))) 47 | -------------------------------------------------------------------------------- /base/chapter8/full-system/scratch.scm: -------------------------------------------------------------------------------- 1 | (error-in-defn-of-module: 2 | curry1 3 | expected-type: 4 | (struct:proc-iface 5 | m2 6 | (struct:simple-iface 7 | ((struct:opaque-type-decl t) 8 | (struct:val-decl 9 | d 10 | (struct:proc-type (struct:named-type t) (struct:named-type t))))) 11 | (struct:simple-iface 12 | ((struct:transparent-type-decl t (struct:qualified-type m2 t)) 13 | (struct:val-decl z (struct:named-type t)) 14 | (struct:val-decl 15 | s 16 | (struct:proc-type (struct:named-type t) (struct:named-type t))) 17 | (struct:val-decl 18 | d 19 | (struct:proc-type (struct:named-type t) (struct:named-type t)))))) 20 | actual-type: 21 | (struct:proc-iface 22 | m2 23 | (struct:simple-iface 24 | ((struct:transparent-type-decl t (struct:qualified-type ints-1 t)) 25 | (struct:val-decl 26 | d 27 | (struct:proc-type (struct:named-type t) (struct:named-type t))))) 28 | (struct:simple-iface 29 | ((struct:transparent-type-decl t (struct:qualified-type ints-1 t)) 30 | (struct:val-decl z (struct:named-type t)) 31 | (struct:val-decl 32 | s 33 | (struct:proc-type (struct:named-type t) (struct:named-type t))) 34 | (struct:val-decl 35 | d 36 | (struct:proc-type 37 | (struct:named-type t) 38 | (struct:named-type t))))))) 39 | 40 | (define foo 41 | (lambda (x y) 42 | (cond 43 | ((eqv? x y) x) 44 | ((and (pair? x) (pair? y) 45 | (= (length x) (length y)) 46 | (map foo x y)) 47 | (else '**)))) -------------------------------------------------------------------------------- /ch2/21.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | (define value? 4 | (lambda (v) 5 | #t)) 6 | 7 | (define-datatype env env? 8 | (empty-env-inter) 9 | (apply-env-inter 10 | (_var symbol?) 11 | (_env env?)) 12 | (extend-env-inter 13 | (_var symbol?) 14 | (_val value?) 15 | (_env env?)) 16 | (has-binding-inter 17 | (_var symbol?) 18 | (_env env?))) 19 | 20 | (define empty-env 21 | (lambda () 22 | (empty-env-inter))) 23 | 24 | (define extend-env 25 | (lambda (var val E) 26 | (extend-env-inter var val E))) 27 | 28 | (define apply-env 29 | (lambda (var E) 30 | (cases env E 31 | (empty-env-inter () 32 | (error 'apply-env "Empty env")) 33 | (extend-env-inter (_var _val _env) 34 | (if (eqv? _var var) 35 | _val 36 | (apply-env var _env))) 37 | (apply-env-inter (_var _env) 38 | (error 'apply-env "error")) 39 | (has-binding-inter (_var _env) 40 | (error 'apply-env "error"))))) 41 | 42 | (define has-binding? 43 | (lambda (var E) 44 | (cases env E 45 | (empty-env-inter () #f) 46 | (extend-env-inter (_var _val _env) 47 | (if (eqv? _var var) 48 | #t 49 | (has-binding? var _env))) 50 | (apply-env-inter (_var _env) 51 | (has-binding? var _env)) 52 | (has-binding-inter (_var _env) 53 | (has-binding? var _env))))) 54 | 55 | 56 | (define e (empty-env)) 57 | (define e (extend-env 'a 1 e)) 58 | (define e (extend-env 'a 2 e)) 59 | (define e (extend-env 'b 3 e)) 60 | 61 | (equal?? (apply-env 'a e) 2) 62 | (equal?? (apply-env 'b e) 3) 63 | 64 | (equal?? (has-binding? 'a e) #t) 65 | (equal?? (has-binding? 'b e) #t) 66 | (equal?? (has-binding? 'z e) #f) 67 | -------------------------------------------------------------------------------- /ch9/07.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/classes/test.scm") 3 | (load-relative "./base/classes/store.scm") 4 | (load-relative "./base/classes/data-structures.scm") 5 | (load-relative "./base/classes/environments.scm") 6 | (load-relative "./base/classes/lang.scm") 7 | (load-relative "./base/classes/interp.scm") 8 | (load-relative "./base/classes/classes.scm") 9 | (load-relative "./base/classes/class-cases.scm") 10 | 11 | ;; see new stuff 12 | 13 | ;; remove the append-field-names part for field-names 14 | (define initialize-class-decl! 15 | (lambda (c-decl) 16 | (cases class-decl c-decl 17 | (a-class-decl (c-name s-name f-names m-decls) 18 | (add-to-class-env! 19 | c-name 20 | (a-class s-name f-names 21 | (merge-method-envs 22 | (class->method-env (lookup-class s-name)) 23 | (method-decls->method-env 24 | m-decls s-name f-names)))))))) 25 | 26 | 27 | 28 | (run "class c1 extends object 29 | field ivar1 30 | method initialize() set ivar1 = 1 31 | 32 | class c2 extends c1 33 | field ivar2 34 | method initialize() 35 | begin 36 | super initialize(); 37 | set ivar2 = 2 38 | end 39 | method setiv1(n) set ivar1 = n %execute error 40 | method getiv1() ivar1 %execute error 41 | method setiv2(n) set ivar2 = n 42 | method getiv2() ivar2 43 | 44 | let o = new c2 () 45 | t1 = 0 46 | in begin 47 | send o setiv2(33); 48 | send o getiv2() 49 | end") 50 | 51 | ;; => 33 52 | 53 | (run-all) 54 | -------------------------------------------------------------------------------- /base/chapter3/proc-lang/ds-rep/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | ;; builds environment interface, using data structures defined in 4 | ;; data-structures.scm. 5 | 6 | (require "data-structures.scm") 7 | 8 | (provide init-env empty-env extend-env apply-env) 9 | 10 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 11 | 12 | ;; init-env : () -> Env 13 | ;; usage: (init-env) = [i=1, v=5, x=10] 14 | ;; (init-env) builds an environment in which i is bound to the 15 | ;; expressed value 1, v is bound to the expressed value 5, and x is 16 | ;; bound to the expressed value 10. 17 | ;; Page: 69 18 | (define init-env 19 | (lambda () 20 | (extend-env 21 | 'i (num-val 1) 22 | (extend-env 23 | 'v (num-val 5) 24 | (extend-env 25 | 'x (num-val 10) 26 | (empty-env)))))) 27 | 28 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 29 | 30 | (define empty-env 31 | (lambda () 32 | (empty-env-record))) 33 | 34 | (define empty-env? 35 | (lambda (x) 36 | (empty-env-record? x))) 37 | 38 | (define extend-env 39 | (lambda (sym val old-env) 40 | (extended-env-record sym val old-env))) 41 | 42 | (define apply-env 43 | (lambda (env search-sym) 44 | (if (empty-env? env) 45 | (eopl:error 'apply-env "No binding for ~s" search-sym) 46 | (let ((sym (extended-env-record->sym env)) 47 | (val (extended-env-record->val env)) 48 | (old-env (extended-env-record->old-env env))) 49 | (if (eqv? search-sym sym) 50 | val 51 | (apply-env old-env search-sym)))))) 52 | 53 | ) -------------------------------------------------------------------------------- /ch2/01.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | ;; Implement for bigint numbers 3 | (define base 16) 4 | (define bzero '()) 5 | (define bzero? null?) 6 | 7 | (define succ 8 | (lambda (n) 9 | (if (bzero? n) 10 | '(1) 11 | (let ((t (+ (car n) 1))) 12 | (if (= t base) 13 | (cons 0 (succ (cdr n))) 14 | (cons t (cdr n))))))) 15 | 16 | (define pred 17 | (lambda (n) 18 | (cond 19 | ((bzero? n) #f) 20 | ((>= (car n) base) #f) 21 | ((equal? n '(1)) '()) 22 | ((zero? (car n)) 23 | (if (null? (cdr n)) 24 | #f 25 | (cons (- base 1) (pred (cdr n))))) 26 | (else (cons (- (car n) 1) (cdr n)))))) 27 | 28 | ;; use mult for better performance 29 | (define make 30 | (lambda (n) 31 | (if (zero? n) 32 | '() 33 | (if (odd? n) 34 | (succ (make (- n 1))) 35 | (mult (make (/ n 2)) '(2)))))) 36 | 37 | (define plus 38 | (lambda (a b) 39 | (if (bzero? b) 40 | a 41 | (plus (succ a) (pred b))))) 42 | 43 | 44 | (define bone? 45 | (lambda (n) 46 | (bzero? (pred n)))) 47 | 48 | (define mult 49 | (lambda (a b) 50 | (cond 51 | ((bzero? b) '()) 52 | ((bone? b) a) 53 | (else 54 | (plus a (mult a (pred b))))))) 55 | 56 | (define fact 57 | (lambda (n) 58 | (cond 59 | ((bzero? n) '()) 60 | ((bone? n) '(1)) 61 | (else 62 | (mult n (fact (pred n))))))) 63 | 64 | (define fact-number 65 | (lambda (n) 66 | (cond 67 | ((zero? n) 0) 68 | ((= n 1) 1) 69 | (else 70 | (* n (fact-number (- n 1))))))) 71 | 72 | 73 | (equal?? (make 10) '(10)) 74 | (equal?? (make 16) '(0 1)) 75 | (make 5040) 76 | (equal?? (fact (make 7)) (make 5040)) 77 | 78 | ;;fact is much slower than fact-number 79 | -------------------------------------------------------------------------------- /base/chapter3/proc-lang/proc-rep/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | ;; builds environment interface, using data structures defined in 4 | ;; data-structures.scm. 5 | 6 | (require "data-structures.scm") 7 | 8 | (provide init-env empty-env extend-env apply-env) 9 | 10 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 11 | 12 | ;; init-env : () -> Env 13 | ;; usage: (init-env) = [i=1, v=5, x=10] 14 | ;; (init-env) builds an environment in which i is bound to the 15 | ;; expressed value 1, v is bound to the expressed value 5, and x is 16 | ;; bound to the expressed value 10. 17 | ;; Page: 69 18 | (define init-env 19 | (lambda () 20 | (extend-env 21 | 'i (num-val 1) 22 | (extend-env 23 | 'v (num-val 5) 24 | (extend-env 25 | 'x (num-val 10) 26 | (empty-env)))))) 27 | 28 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 29 | 30 | (define empty-env 31 | (lambda () 32 | (empty-env-record))) 33 | 34 | (define empty-env? 35 | (lambda (x) 36 | (empty-env-record? x))) 37 | 38 | (define extend-env 39 | (lambda (sym val old-env) 40 | (extended-env-record sym val old-env))) 41 | 42 | (define apply-env 43 | (lambda (env search-sym) 44 | (if (empty-env? env) 45 | (eopl:error 'apply-env "No binding for ~s" search-sym) 46 | (let ((sym (extended-env-record->sym env)) 47 | (val (extended-env-record->val env)) 48 | (old-env (extended-env-record->old-env env))) 49 | (if (eqv? search-sym sym) 50 | val 51 | (apply-env old-env search-sym)))))) 52 | 53 | ) 54 | -------------------------------------------------------------------------------- /ch9/base/typed-oo/static-data-structures.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; type environments ;;;;;;;;;;;;;;;; 2 | 3 | (define-datatype type-environment type-environment? 4 | (empty-tenv) 5 | (extend-tenv 6 | (syms (list-of symbol?)) 7 | (vals (list-of type?)) 8 | (tenv type-environment?)) 9 | (extend-tenv-with-self-and-super 10 | (self type?) 11 | (super-name symbol?) 12 | (saved-env type-environment?))) 13 | 14 | (define init-tenv 15 | (lambda () 16 | (extend-tenv 17 | '(i v x) 18 | (list (int-type) (int-type) (int-type)) 19 | (empty-tenv)))) 20 | 21 | (define apply-tenv 22 | (lambda (env search-sym) 23 | (cases type-environment env 24 | (empty-tenv () 25 | (error 'apply-tenv "No type found for ~s" search-sym)) 26 | (extend-tenv (bvars types saved-env) 27 | (cond 28 | ((location search-sym bvars) 29 | => (lambda (n) (list-ref types n))) 30 | (else 31 | (apply-tenv saved-env search-sym)))) 32 | (extend-tenv-with-self-and-super (self-name super-name saved-env) 33 | (case search-sym 34 | ((%self) self-name) 35 | ((%super) super-name) 36 | (else (apply-tenv saved-env search-sym))))))) 37 | 38 | (define location 39 | (lambda (sym syms) 40 | (cond 41 | ((null? syms) #f) 42 | ((eqv? sym (car syms)) 0) 43 | ((location sym (cdr syms)) => (lambda (n) (+ n 1))) 44 | (else #f)))) 45 | -------------------------------------------------------------------------------- /base/chapter2/sec2.2-ds-rep.scm: -------------------------------------------------------------------------------- 1 | (module sec2.2-ds-rep (lib "eopl.ss" "eopl") 2 | 3 | ;; Simple data structure representation of environments 4 | ;; Page: 38 5 | 6 | (require "utils.scm") 7 | 8 | ;; data definition: 9 | ;; Env ::= (empty-env) | (extend-env Var Schemeval Env) 10 | 11 | ;; empty-env : () -> Env 12 | (define empty-env 13 | (lambda () (list 'empty-env))) 14 | 15 | ;; extend-env : Var * Schemeval * Env -> Env 16 | (define extend-env 17 | (lambda (var val env) 18 | (list 'extend-env var val env))) 19 | 20 | ;; apply-env : Env * Var -> Schemeval 21 | (define apply-env 22 | (lambda (env search-var) 23 | (cond 24 | ((eqv? (car env) 'empty-env) 25 | (report-no-binding-found search-var)) 26 | ((eqv? (car env) 'extend-env) 27 | (let ((saved-var (cadr env)) 28 | (saved-val (caddr env)) 29 | (saved-env (cadddr env))) 30 | (if (eqv? search-var saved-var) 31 | saved-val 32 | (apply-env saved-env search-var)))) 33 | (else 34 | (report-invalid-env env))))) 35 | 36 | (define report-no-binding-found 37 | (lambda (search-var) 38 | (eopl:error 'apply-env "No binding for ~s" search-var))) 39 | 40 | (define report-invalid-env 41 | (lambda (env) 42 | (eopl:error 'apply-env "Bad environment: ~s" env))) 43 | 44 | (define e 45 | (extend-env 'd 6 46 | (extend-env 'y 8 47 | (extend-env 'x 7 48 | (extend-env 'y 14 49 | (empty-env)))))) 50 | 51 | (equal?? (apply-env e 'd) 6) 52 | (equal?? (apply-env e 'y) 8) 53 | (equal?? (apply-env e 'x) 7) 54 | 55 | (report-unit-tests-completed 'apply-env) 56 | 57 | ) 58 | -------------------------------------------------------------------------------- /ch6/base/let-lang.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 2 | 3 | (define the-lexical-spec 4 | '((whitespace (whitespace) skip) 5 | (comment ("%" (arbno (not #\newline))) skip) 6 | (identifier 7 | (letter (arbno (or letter digit "_" "-" "?"))) 8 | symbol) 9 | (number (digit (arbno digit)) number) 10 | (number ("-" digit (arbno digit)) number) 11 | )) 12 | 13 | (define the-grammar 14 | '((program (expression) a-program) 15 | 16 | (expression (number) const-exp) 17 | (expression 18 | ("-" "(" expression "," expression ")") 19 | diff-exp) 20 | 21 | (expression 22 | ("zero?" "(" expression ")") 23 | zero?-exp) 24 | 25 | (expression 26 | ("if" expression "then" expression "else" expression) 27 | if-exp) 28 | 29 | (expression (identifier) var-exp) 30 | 31 | (expression 32 | ("let" identifier "=" expression "in" expression) 33 | let-exp) 34 | 35 | (expression 36 | ("proc" "(" identifier ")" expression) 37 | proc-exp) 38 | 39 | (expression 40 | ("(" expression expression ")") 41 | call-exp) 42 | 43 | (expression 44 | ("letrec" 45 | identifier "(" identifier ")" "=" expression 46 | "in" expression) 47 | letrec-exp) 48 | 49 | )) 50 | 51 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 52 | 53 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 54 | 55 | (define show-the-datatypes 56 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 57 | 58 | (define scan&parse 59 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 60 | 61 | (define just-scan 62 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 63 | -------------------------------------------------------------------------------- /ch2/11.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | 4 | (define empty-env 5 | (lambda() '())) 6 | 7 | 8 | (define extend-env 9 | (lambda (var val env) 10 | (cons (list 11 | (list var) (list val)) 12 | env))) 13 | 14 | (define extend-env* 15 | (lambda (var-list val-list env) 16 | (if (null? var-list) 17 | env 18 | (cons (list var-list val-list) 19 | env)))) 20 | 21 | ;; return a pair, for distinguish with val is #f 22 | (define apply-current 23 | (lambda (vars vals search-var) 24 | (if (null? vars) 25 | (cons #f '()) 26 | (if (eqv? (car vars) search-var) 27 | (cons #t (car vals)) 28 | (apply-current (cdr vars) (cdr vals) search-var))))) 29 | 30 | (define apply-env 31 | (lambda (env search-var) 32 | (if (null? env) 33 | (report-no-binding-found search-var) 34 | (let ((val (apply-current (caar env) (cadar env) search-var))) 35 | (if (car val) (cdr val) 36 | (apply-env (cdr env) search-var)))))) 37 | 38 | (define report-no-binding-found 39 | (lambda (search-var) 40 | (error 'apply-env "No binding for: " search-var))) 41 | 42 | 43 | (define has-binding? 44 | (lambda (env var) 45 | (if (null? env) 46 | #f 47 | (let ((val (apply-current (caar env) (cadar env) var))) 48 | (if (car val) 49 | #t 50 | (has-binding? (cdr env) var)))))) 51 | 52 | 53 | (define e (empty-env)) 54 | (equal?? e '()) 55 | 56 | (define e (extend-env 'z 10 e)) 57 | (equal?? e '(((z) (10)))) 58 | 59 | (define e (extend-env* '(a b c d) '(1 2 3 4) e)) 60 | (equal?? e '(((a b c d) (1 2 3 4)) ((z) (10)))) 61 | 62 | (equal?? (apply-env e 'z) 10) 63 | (equal?? (apply-env e 'd) 4) 64 | 65 | (equal?? (has-binding? e 'z) #t) 66 | (equal?? (has-binding? e 'd) #t) 67 | (equal?? (has-binding? e 'm) #f) 68 | -------------------------------------------------------------------------------- /ch2/14.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; data definition: 4 | ;; Env = Var -> Schemeval 5 | 6 | ;; empty-env : () -> Env 7 | (define empty-env 8 | (lambda () 9 | (list (lambda (search-var) 10 | (report-no-binding-found search-var)) 11 | (lambda (search-var) 12 | #f) 13 | (lambda () 14 | #t)))) 15 | 16 | 17 | ;; extend-env : Var * Schemeval * Env -> Env 18 | (define extend-env 19 | (lambda (saved-var saved-val saved-env) 20 | (list (lambda (search-var) 21 | (if (eqv? search-var saved-var) 22 | saved-val 23 | (apply-env saved-env search-var))) 24 | (lambda (search-var) 25 | (if (eqv? search-var saved-var) 26 | #t 27 | (has-binding? saved-env search-var))) 28 | (lambda () 29 | #f)))) 30 | 31 | ;; apply-env : Env * Var -> Schemeval 32 | (define apply-env 33 | (lambda (env search-var) 34 | ((car env) search-var))) 35 | 36 | (define has-binding? 37 | (lambda (env search-var) 38 | ((cadr env) search-var))) 39 | 40 | (define empty-env? 41 | (lambda (env) 42 | ((caddr env)))) 43 | 44 | (define report-no-binding-found 45 | (lambda (search-var) 46 | (error 'apply-env "No binding for ~s" search-var))) 47 | 48 | (define report-invalid-env 49 | (lambda (env) 50 | (error 'apply-env "Bad environment: ~s" env))) 51 | 52 | (define e 53 | (extend-env 'd 6 54 | (extend-env 'y 8 55 | (extend-env 'x 7 56 | (extend-env 'y 14 57 | (empty-env)))))) 58 | 59 | (equal?? (apply-env e 'd) 6) 60 | (equal?? (apply-env e 'y) 8) 61 | (equal?? (apply-env e 'x) 7) 62 | 63 | (equal?? (empty-env? (empty-env)) #t) 64 | (equal?? (empty-env? e) #f) 65 | 66 | (equal?? (has-binding? e 'd) #t) 67 | (equal?? (has-binding? e 'x) #t) 68 | (equal?? (has-binding? e 'm) #f) 69 | -------------------------------------------------------------------------------- /ch8/14.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/test.scm") 3 | (load-relative "./base/data-structures.scm") 4 | (load-relative "./base/type-structures.scm") 5 | (load-relative "./base/type-module.scm") 6 | (load-relative "./base/grammar.scm") 7 | (load-relative "./base/renaming.scm") 8 | (load-relative "./base/subtyping.scm") 9 | (load-relative "./base/expand-type.scm") 10 | (load-relative "./base/type-cases.scm") 11 | 12 | 13 | (run "module mybool 14 | interface 15 | [opaque t 16 | true : t 17 | false : t 18 | and : (t -> (t -> t)) 19 | not : (t -> t) 20 | to-bool : (t -> bool)] 21 | body 22 | [type t = int 23 | true = 0 24 | false = 13 25 | and = proc (x : t) 26 | proc (y : t) 27 | if zero?(x) then y else false 28 | not = proc (x : t) 29 | if zero?(x) then false else true 30 | to-bool = proc (x : t) zero?(x)] 31 | let true = from mybool take true 32 | in let false = from mybool take false in let and = from mybool take and 33 | in ((and true) false)") 34 | 35 | ;; => (num-val 13) 36 | 37 | (run "module mybool 38 | interface 39 | [opaque t 40 | true : t 41 | false : t 42 | and : (t -> (t -> t)) 43 | not : (t -> t) 44 | to-bool : (t -> bool)] 45 | body 46 | [type t = int 47 | true = 1 48 | false = 0 49 | and = proc (x : t) 50 | proc (y : t) 51 | if zero?(x) then false else y 52 | not = proc (x : t) 53 | if zero?(x) then true else false 54 | to-bool = proc (x : t) 55 | if zero?(x) then zero?(1) else zero?(0)] 56 | 57 | let true = from mybool take true 58 | in let false = from mybool take false in let and = from mybool take and 59 | in ((and true) false)") 60 | 61 | ;; => (num-val 0) 62 | -------------------------------------------------------------------------------- /base/chapter7/checked/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined)) ; too many things to list 6 | 7 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 8 | 9 | ;;; an expressed value is either a number, a boolean or a procval. 10 | 11 | (define-datatype expval expval? 12 | (num-val 13 | (value number?)) 14 | (bool-val 15 | (boolean boolean?)) 16 | (proc-val 17 | (proc proc?))) 18 | 19 | ;;; extractors: 20 | 21 | (define expval->num 22 | (lambda (v) 23 | (cases expval v 24 | (num-val (num) num) 25 | (else (expval-extractor-error 'num v))))) 26 | 27 | (define expval->bool 28 | (lambda (v) 29 | (cases expval v 30 | (bool-val (bool) bool) 31 | (else (expval-extractor-error 'bool v))))) 32 | 33 | (define expval->proc 34 | (lambda (v) 35 | (cases expval v 36 | (proc-val (proc) proc) 37 | (else (expval-extractor-error 'proc v))))) 38 | 39 | (define expval-extractor-error 40 | (lambda (variant value) 41 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 42 | variant value))) 43 | 44 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 45 | 46 | (define-datatype proc proc? 47 | (procedure 48 | (bvar symbol?) 49 | (body expression?) 50 | (env environment?))) 51 | 52 | (define-datatype environment environment? 53 | (empty-env) 54 | (extend-env 55 | (bvar symbol?) 56 | (bval expval?) 57 | (saved-env environment?)) 58 | (extend-env-rec 59 | (p-name symbol?) 60 | (b-var symbol?) 61 | (p-body expression?) 62 | (saved-env environment?))) 63 | 64 | ) -------------------------------------------------------------------------------- /base/chapter7/inferred/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined)) ; too many things to list 6 | 7 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 8 | 9 | ;;; an expressed value is either a number, a boolean or a procval. 10 | 11 | (define-datatype expval expval? 12 | (num-val 13 | (value number?)) 14 | (bool-val 15 | (boolean boolean?)) 16 | (proc-val 17 | (proc proc?))) 18 | 19 | ;;; extractors: 20 | 21 | (define expval->num 22 | (lambda (v) 23 | (cases expval v 24 | (num-val (num) num) 25 | (else (expval-extractor-error 'num v))))) 26 | 27 | (define expval->bool 28 | (lambda (v) 29 | (cases expval v 30 | (bool-val (bool) bool) 31 | (else (expval-extractor-error 'bool v))))) 32 | 33 | (define expval->proc 34 | (lambda (v) 35 | (cases expval v 36 | (proc-val (proc) proc) 37 | (else (expval-extractor-error 'proc v))))) 38 | 39 | (define expval-extractor-error 40 | (lambda (variant value) 41 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 42 | variant value))) 43 | 44 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 45 | 46 | (define-datatype proc proc? 47 | (procedure 48 | (bvar symbol?) 49 | (body expression?) 50 | (env environment?))) 51 | 52 | (define-datatype environment environment? 53 | (empty-env) 54 | (extend-env 55 | (bvar symbol?) 56 | (bval expval?) 57 | (saved-env environment?)) 58 | (extend-env-rec 59 | (p-name symbol?) 60 | (b-var symbol?) 61 | (p-body expression?) 62 | (saved-env environment?))) 63 | 64 | ) -------------------------------------------------------------------------------- /base/chapter9/typed-oo/static-data-structures.scm: -------------------------------------------------------------------------------- 1 | (module static-data-structures (lib "eopl.ss" "eopl") 2 | 3 | ;; type environments and associated procedures. 4 | ;; In chapter7/checked, this is in checker.scm. 5 | 6 | (require "lang.scm") 7 | 8 | (provide (all-defined)) 9 | 10 | ;;;;;;;;;;;;;;;; type environments ;;;;;;;;;;;;;;;; 11 | 12 | (define-datatype type-environment type-environment? 13 | (empty-tenv) 14 | (extend-tenv 15 | (syms (list-of symbol?)) 16 | (vals (list-of type?)) 17 | (tenv type-environment?)) 18 | (extend-tenv-with-self-and-super 19 | (self type?) 20 | (super-name symbol?) 21 | (saved-env type-environment?))) 22 | 23 | (define init-tenv 24 | (lambda () 25 | (extend-tenv 26 | '(i v x) 27 | (list (int-type) (int-type) (int-type)) 28 | (empty-tenv)))) 29 | 30 | (define apply-tenv 31 | (lambda (env search-sym) 32 | (cases type-environment env 33 | (empty-tenv () 34 | (eopl:error 'apply-tenv "No type found for ~s" search-sym)) 35 | (extend-tenv (bvars types saved-env) 36 | (cond 37 | ((location search-sym bvars) 38 | => (lambda (n) (list-ref types n))) 39 | (else 40 | (apply-tenv saved-env search-sym)))) 41 | (extend-tenv-with-self-and-super (self-name super-name saved-env) 42 | (case search-sym 43 | ((%self) self-name) 44 | ((%super) super-name) 45 | (else (apply-tenv saved-env search-sym))))))) 46 | 47 | (define location 48 | (lambda (sym syms) 49 | (cond 50 | ((null? syms) #f) 51 | ((eqv? sym (car syms)) 0) 52 | ((location sym (cdr syms)) => (lambda (n) (+ n 1))) 53 | (else #f)))) 54 | 55 | 56 | ) -------------------------------------------------------------------------------- /base/chapter3/let-lang/data-structures.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 2 | 3 | ;;; an expressed value is either a number, a boolean or a procval. 4 | 5 | (define-datatype expval expval? 6 | (num-val 7 | (value number?)) 8 | (bool-val 9 | (boolean boolean?))) 10 | 11 | ;;; extractors: 12 | 13 | ;; expval->num : ExpVal -> Int 14 | ;; Page: 70 15 | (define expval->num 16 | (lambda (v) 17 | (cases expval v 18 | (num-val (num) num) 19 | (else (expval-extractor-error 'num v))))) 20 | 21 | ;; expval->bool : ExpVal -> Bool 22 | ;; Page: 70 23 | (define expval->bool 24 | (lambda (v) 25 | (cases expval v 26 | (bool-val (bool) bool) 27 | (else (expval-extractor-error 'bool v))))) 28 | 29 | (define expval-extractor-error 30 | (lambda (variant value) 31 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 32 | variant value))) 33 | 34 | ;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;; 35 | 36 | ;; example of a data type built without define-datatype 37 | 38 | (define empty-env-record 39 | (lambda () 40 | '())) 41 | 42 | (define extended-env-record 43 | (lambda (sym val old-env) 44 | (cons (list sym val) old-env))) 45 | 46 | (define empty-env-record? null?) 47 | 48 | (define environment? 49 | (lambda (x) 50 | (or (empty-env-record? x) 51 | (and (pair? x) 52 | (symbol? (car (car x))) 53 | (expval? (cadr (car x))) 54 | (environment? (cdr x)))))) 55 | 56 | (define extended-env-record->sym 57 | (lambda (r) 58 | (car (car r)))) 59 | 60 | (define extended-env-record->val 61 | (lambda (r) 62 | (cadr (car r)))) 63 | 64 | (define extended-env-record->old-env 65 | (lambda (r) 66 | (cdr r))) 67 | -------------------------------------------------------------------------------- /base/chapter3/proc-lang/ds-rep/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; grammar for the PROC language 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined)) 8 | 9 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 10 | 11 | (define the-lexical-spec 12 | '((whitespace (whitespace) skip) 13 | (comment ("%" (arbno (not #\newline))) skip) 14 | (identifier 15 | (letter (arbno (or letter digit "_" "-" "?"))) 16 | symbol) 17 | (number (digit (arbno digit)) number) 18 | (number ("-" digit (arbno digit)) number) 19 | )) 20 | 21 | (define the-grammar 22 | '((program (expression) a-program) 23 | 24 | (expression (number) const-exp) 25 | (expression 26 | ("-" "(" expression "," expression ")") 27 | diff-exp) 28 | 29 | (expression 30 | ("zero?" "(" expression ")") 31 | zero?-exp) 32 | 33 | (expression 34 | ("if" expression "then" expression "else" expression) 35 | if-exp) 36 | 37 | (expression (identifier) var-exp) 38 | 39 | (expression 40 | ("let" identifier "=" expression "in" expression) 41 | let-exp) 42 | 43 | (expression 44 | ("proc" "(" identifier ")" expression) 45 | proc-exp) 46 | 47 | (expression 48 | ("(" expression expression ")") 49 | call-exp) 50 | 51 | )) 52 | 53 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 54 | 55 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 56 | 57 | (define show-the-datatypes 58 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 59 | 60 | (define scan&parse 61 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 62 | 63 | (define just-scan 64 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 65 | 66 | ) 67 | -------------------------------------------------------------------------------- /ch9/base/classes/top.scm: -------------------------------------------------------------------------------- 1 | ;; top level module. Loads all required pieces. 2 | ;; Run the test suite with (run-all). 3 | 4 | (require "drscheme-init.scm") 5 | (require "data-structures.scm") ; for expval constructors 6 | (require "lang.scm") ; for scan&parse 7 | (require "interp.scm") ; for value-of-program 8 | (require "tests.scm") ; for test-list 9 | 10 | (provide run run-all) 11 | 12 | 13 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 14 | 15 | ;; run : String -> ExpVal 16 | 17 | (define run 18 | (lambda (string) 19 | (value-of-program (scan&parse string)))) 20 | 21 | ;; run-all : () -> Unspecified 22 | 23 | ;; runs all the tests in test-list, comparing the results with 24 | ;; equal-answer? 25 | 26 | (define run-all 27 | (lambda () 28 | (run-tests! run equal-answer? test-list))) 29 | 30 | (define equal-answer? 31 | (lambda (ans correct-ans) 32 | (equal? ans (sloppy->expval correct-ans)))) 33 | 34 | (define sloppy->expval 35 | (lambda (sloppy-val) 36 | (cond 37 | ((number? sloppy-val) (num-val sloppy-val)) 38 | ((boolean? sloppy-val) (bool-val sloppy-val)) 39 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 40 | (else 41 | (error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : Sym -> ExpVal 46 | 47 | ;; (run-one sym) runs the test whose name is sym 48 | 49 | (define run-one 50 | (lambda (test-name) 51 | (let ((the-test (assoc test-name test-list))) 52 | (cond 53 | ((assoc test-name test-list) 54 | => (lambda (test) 55 | (run (cadr test)))) 56 | (else (error 'run-one "no such test: ~s" test-name)))))) 57 | 58 | ;; (run-all) 59 | -------------------------------------------------------------------------------- /ch8/base/renaming.scm: -------------------------------------------------------------------------------- 1 | (define rename-in-iface 2 | (lambda (m-type old new) 3 | (cases interface m-type 4 | (simple-iface (decls) 5 | (simple-iface 6 | (rename-in-decls decls old new))) ))) 7 | 8 | ;; this isn't a map because we have let* scoping in a list of declarations 9 | (define rename-in-decls 10 | (lambda (decls old new) 11 | (if (null? decls) '() 12 | (let ((decl (car decls)) 13 | (decls (cdr decls))) 14 | (cases declaration decl 15 | (val-decl (name ty) 16 | (cons 17 | (val-decl name (rename-in-type ty old new)) 18 | (rename-in-decls decls old new))) 19 | (opaque-type-decl (name) 20 | (cons 21 | (opaque-type-decl name) 22 | (if (eqv? name old) 23 | decls 24 | (rename-in-decls decls old new)))) 25 | (transparent-type-decl (name ty) 26 | (cons 27 | (transparent-type-decl 28 | name 29 | (rename-in-type ty old new)) 30 | (if (eqv? name old) 31 | decls 32 | (rename-in-decls decls old new)))) 33 | ))))) 34 | 35 | (define rename-in-type 36 | (lambda (ty old new) 37 | (let recur ((ty ty)) 38 | (cases type ty 39 | (named-type (id) 40 | (named-type (rename-name id old new))) 41 | (qualified-type (m-name name) 42 | (qualified-type 43 | (rename-name m-name old new) 44 | name)) 45 | (proc-type (t1 t2) 46 | (proc-type (recur t1) (recur t2))) 47 | (else ty) ; this covers int, bool, and unknown. 48 | )))) 49 | 50 | (define rename-name 51 | (lambda (name old new) 52 | (if (eqv? name old) new name))) 53 | 54 | (define fresh-module-name 55 | (let ((sn 0)) 56 | (lambda (module-name) 57 | (set! sn (+ sn 1)) 58 | (string->symbol 59 | (string-append 60 | (symbol->string module-name) 61 | "%" ; this can't appear in an input identifier 62 | (number->string sn)))))) 63 | -------------------------------------------------------------------------------- /base/chapter3/proc-lang/ds-rep/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | (define run 18 | (lambda (string) 19 | (value-of-program (scan&parse string)))) 20 | 21 | ;; run-all : () -> Unspecified 22 | ;; runs all the tests in test-list, comparing the results with 23 | ;; equal-answer? 24 | (define run-all 25 | (lambda () 26 | (run-tests! run equal-answer? test-list))) 27 | 28 | (define equal-answer? 29 | (lambda (ans correct-ans) 30 | (equal? ans (sloppy->expval correct-ans)))) 31 | 32 | (define sloppy->expval 33 | (lambda (sloppy-val) 34 | (cond 35 | ((number? sloppy-val) (num-val sloppy-val)) 36 | ((boolean? sloppy-val) (bool-val sloppy-val)) 37 | (else 38 | (eopl:error 'sloppy->expval 39 | "Can't convert sloppy value to expval: ~s" 40 | sloppy-val))))) 41 | 42 | ;; run-one : Sym -> ExpVal 43 | ;; (run-one sym) runs the test whose name is sym 44 | (define run-one 45 | (lambda (test-name) 46 | (let ((the-test (assoc test-name test-list))) 47 | (cond 48 | ((assoc test-name test-list) 49 | => (lambda (test) 50 | (run (cadr test)))) 51 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 52 | 53 | ;; (run-all) 54 | 55 | ) 56 | 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /base/chapter4/implicit-refs/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | 18 | (define run 19 | (lambda (string) 20 | (value-of-program (scan&parse string)))) 21 | 22 | ;; run-all : () -> Unspecified 23 | 24 | ;; runs all the tests in test-list, comparing the results with 25 | ;; equal-answer? 26 | 27 | (define run-all 28 | (lambda () 29 | (run-tests! run equal-answer? test-list))) 30 | 31 | (define equal-answer? 32 | (lambda (ans correct-ans) 33 | (equal? ans (sloppy->expval correct-ans)))) 34 | 35 | (define sloppy->expval 36 | (lambda (sloppy-val) 37 | (cond 38 | ((number? sloppy-val) (num-val sloppy-val)) 39 | ((boolean? sloppy-val) (bool-val sloppy-val)) 40 | (else 41 | (eopl:error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : Sym -> ExpVal 46 | ;; (run-one sym) runs the test whose name is sym 47 | (define run-one 48 | (lambda (test-name) 49 | (let ((the-test (assoc test-name test-list))) 50 | (cond 51 | ((assoc test-name test-list) 52 | => (lambda (test) 53 | (run (cadr test)))) 54 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 55 | 56 | ;; (run-all) 57 | 58 | ) 59 | 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /base/chapter3/proc-lang/proc-rep/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; grammar for the PROC language 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined)) 8 | 9 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 10 | 11 | (define the-lexical-spec 12 | '((whitespace (whitespace) skip) 13 | (comment ("%" (arbno (not #\newline))) skip) 14 | (identifier 15 | (letter (arbno (or letter digit "_" "-" "?"))) 16 | symbol) 17 | (number (digit (arbno digit)) number) 18 | (number ("-" digit (arbno digit)) number) 19 | )) 20 | 21 | (define the-grammar 22 | '((program (expression) a-program) 23 | 24 | (expression (number) const-exp) 25 | (expression 26 | ("-" "(" expression "," expression ")") 27 | diff-exp) 28 | 29 | (expression 30 | ("zero?" "(" expression ")") 31 | zero?-exp) 32 | 33 | (expression 34 | ("if" expression "then" expression "else" expression) 35 | if-exp) 36 | 37 | (expression (identifier) var-exp) 38 | 39 | (expression 40 | ("let" identifier "=" expression "in" expression) 41 | let-exp) 42 | 43 | (expression 44 | ("proc" "(" identifier ")" expression) 45 | proc-exp) 46 | 47 | (expression 48 | ("(" expression expression ")") 49 | call-exp) 50 | 51 | )) 52 | 53 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 54 | 55 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 56 | 57 | (define show-the-datatypes 58 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 59 | 60 | (define scan&parse 61 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 62 | 63 | (define just-scan 64 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 65 | 66 | ) 67 | -------------------------------------------------------------------------------- /base/chapter5/thread-lang/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all N), where N is the size of the 5 | ;; time slice. 6 | 7 | 8 | (require "drscheme-init.scm") 9 | (require "data-structures.scm") 10 | (require "lang.scm") ; for scan&parse 11 | (require "interp.scm") ; for value-of-program 12 | (require "tests.scm") ; for test-list 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | (define run 17 | (lambda (timeslice string) 18 | (value-of-program timeslice (scan&parse string)))) 19 | 20 | (define run-all 21 | (lambda (timeslice) 22 | (run-tests! 23 | (lambda (string) (run timeslice string)) 24 | equal-answer? test-list))) 25 | 26 | (define run-one 27 | (lambda (timeslice test-name) 28 | (let ((the-test (assoc test-name test-list))) 29 | (cond 30 | ((assoc test-name test-list) 31 | => (lambda (test) 32 | (run timeslice (cadr test)))) 33 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 34 | 35 | (define equal-answer? 36 | (lambda (ans correct-ans) 37 | (equal? ans (sloppy->expval correct-ans)))) 38 | 39 | (define sloppy->expval 40 | (lambda (sloppy-val) 41 | (cond 42 | ((number? sloppy-val) (num-val sloppy-val)) 43 | ((boolean? sloppy-val) (bool-val sloppy-val)) 44 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 45 | (else 46 | (eopl:error 'sloppy->expval 47 | "Can't convert sloppy value to expval: ~s" 48 | sloppy-val))))) 49 | 50 | 51 | ;; (stop-after-first-error #t) 52 | ;; (run-all 5) 53 | ;; (run-one 1000 'producer-consumer) 54 | 55 | ) 56 | 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /base/chapter4/call-by-need/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | (define run 18 | (lambda (string) 19 | (value-of-program (scan&parse string)))) 20 | 21 | ;; run-all : () -> Unspecified 22 | 23 | ;; runs all the tests in test-list, comparing the results with 24 | ;; equal-answer? 25 | 26 | (define run-all 27 | (lambda () 28 | (run-tests! run equal-answer? test-list))) 29 | 30 | (define equal-answer? 31 | (lambda (ans correct-ans) 32 | (equal? ans (sloppy->expval correct-ans)))) 33 | 34 | (define sloppy->expval 35 | (lambda (sloppy-val) 36 | (cond 37 | ((number? sloppy-val) (num-val sloppy-val)) 38 | ((boolean? sloppy-val) (bool-val sloppy-val)) 39 | (else 40 | (eopl:error 'sloppy->expval 41 | "Can't convert sloppy value to expval: ~s" 42 | sloppy-val))))) 43 | 44 | ;; run-one : Sym -> ExpVal 45 | 46 | ;; (run-one sym) runs the test whose name is sym 47 | 48 | (define run-one 49 | (lambda (test-name) 50 | (let ((the-test (assoc test-name test-list))) 51 | (cond 52 | ((assoc test-name test-list) 53 | => (lambda (test) 54 | (run (cadr test)))) 55 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 56 | 57 | ;; (run-all) 58 | 59 | ) 60 | 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /base/chapter4/mutable-pairs/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | 18 | (define run 19 | (lambda (string) 20 | (value-of-program (scan&parse string)))) 21 | 22 | ;; run-all : () -> Unspecified 23 | 24 | ;; runs all the tests in test-list, comparing the results with 25 | ;; equal-answer? 26 | 27 | (define run-all 28 | (lambda () 29 | (run-tests! run equal-answer? test-list))) 30 | 31 | (define equal-answer? 32 | (lambda (ans correct-ans) 33 | (equal? ans (sloppy->expval correct-ans)))) 34 | 35 | (define sloppy->expval 36 | (lambda (sloppy-val) 37 | (cond 38 | ((number? sloppy-val) (num-val sloppy-val)) 39 | ((boolean? sloppy-val) (bool-val sloppy-val)) 40 | (else 41 | (eopl:error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : Sym -> ExpVal 46 | 47 | ;; (run-one sym) runs the test whose name is sym 48 | 49 | (define run-one 50 | (lambda (test-name) 51 | (let ((the-test (assoc test-name test-list))) 52 | (cond 53 | ((assoc test-name test-list) 54 | => (lambda (test) 55 | (run (cadr test)))) 56 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 57 | 58 | ;; (run-all) 59 | 60 | ) 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /base/chapter4/call-by-reference/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | 18 | (define run 19 | (lambda (string) 20 | (value-of-program (scan&parse string)))) 21 | 22 | ;; run-all : () -> Unspecified 23 | 24 | ;; runs all the tests in test-list, comparing the results with 25 | ;; equal-answer? 26 | 27 | (define run-all 28 | (lambda () 29 | (run-tests! run equal-answer? test-list))) 30 | 31 | (define equal-answer? 32 | (lambda (ans correct-ans) 33 | (equal? ans (sloppy->expval correct-ans)))) 34 | 35 | (define sloppy->expval 36 | (lambda (sloppy-val) 37 | (cond 38 | ((number? sloppy-val) (num-val sloppy-val)) 39 | ((boolean? sloppy-val) (bool-val sloppy-val)) 40 | (else 41 | (eopl:error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : Sym -> ExpVal 46 | 47 | ;; (run-one sym) runs the test whose name is sym 48 | 49 | (define run-one 50 | (lambda (test-name) 51 | (let ((the-test (assoc test-name test-list))) 52 | (cond 53 | ((assoc test-name test-list) 54 | => (lambda (test) 55 | (run (cadr test)))) 56 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 57 | 58 | ;; (run-all) 59 | 60 | ) 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /base/chapter4/explicit-refs/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | 18 | (define run 19 | (lambda (string) 20 | (value-of-program (scan&parse string)))) 21 | 22 | ;; run-all : () -> Unspecified 23 | 24 | ;; runs all the tests in test-list, comparing the results with 25 | ;; equal-answer? 26 | 27 | (define run-all 28 | (lambda () 29 | (run-tests! run equal-answer? test-list))) 30 | 31 | (define equal-answer? 32 | (lambda (ans correct-ans) 33 | (equal? ans (sloppy->expval correct-ans)))) 34 | 35 | (define sloppy->expval 36 | (lambda (sloppy-val) 37 | (cond 38 | ((number? sloppy-val) (num-val sloppy-val)) 39 | ((boolean? sloppy-val) (bool-val sloppy-val)) 40 | (else 41 | (eopl:error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : Sym -> ExpVal 46 | 47 | ;; (run-one sym) runs the test whose name is sym 48 | 49 | (define run-one 50 | (lambda (test-name) 51 | (let ((the-test (assoc test-name test-list))) 52 | (cond 53 | ((assoc test-name test-list) 54 | => (lambda (test) 55 | (run (cadr test)))) 56 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 57 | 58 | ;; (run-all) 59 | 60 | ) 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /base/chapter3/proc-lang/proc-rep/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : string -> expval 17 | 18 | (define run 19 | (lambda (string) 20 | (value-of-program (scan&parse string)))) 21 | 22 | ;; run-all : () -> unspecified 23 | 24 | ;; runs all the tests in test-list, comparing the results with 25 | ;; equal-answer? 26 | 27 | (define run-all 28 | (lambda () 29 | (run-tests! run equal-answer? test-list))) 30 | 31 | (define equal-answer? 32 | (lambda (ans correct-ans) 33 | (equal? ans (sloppy->expval correct-ans)))) 34 | 35 | (define sloppy->expval 36 | (lambda (sloppy-val) 37 | (cond 38 | ((number? sloppy-val) (num-val sloppy-val)) 39 | ((boolean? sloppy-val) (bool-val sloppy-val)) 40 | (else 41 | (eopl:error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : symbol -> expval 46 | 47 | ;; (run-one sym) runs the test whose name is sym 48 | 49 | (define run-one 50 | (lambda (test-name) 51 | (let ((the-test (assoc test-name test-list))) 52 | (cond 53 | ((assoc test-name test-list) 54 | => (lambda (test) 55 | (run (cadr test)))) 56 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 57 | 58 | ;; (run-all) 59 | 60 | ) 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /ch2/07.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; we can print out all the var in current env when error happend 4 | ;; use fuction error and printf in scheme 5 | 6 | ;; empty-env : () -> Env 7 | (define empty-env 8 | (lambda () (list 'empty-env))) 9 | 10 | ;; extend-env : Var * Schemeval * Env -> Env 11 | (define extend-env 12 | (lambda (var val env) 13 | (list 'extend-env var val env))) 14 | 15 | ;; apply-env : Env * Var -> Schemeval 16 | (define apply-env-rec 17 | (lambda (env search-var all) 18 | (cond 19 | ((eqv? (car env) 'empty-env) 20 | (report-no-binding-found search-var all)) 21 | ((eqv? (car env) 'extend-env) 22 | (let ((saved-var (cadr env)) 23 | (saved-val (caddr env)) 24 | (saved-env (cadddr env))) 25 | (if (eqv? search-var saved-var) 26 | saved-val 27 | (apply-env-rec saved-env search-var all)))) 28 | (else 29 | (report-invalid-env env))))) 30 | 31 | (define apply-env 32 | (lambda (env search-var) 33 | (apply-env-rec env search-var env))) 34 | 35 | 36 | (define display-env-rec 37 | (lambda (env) 38 | (if (eqv? (car env) 'extend-env) 39 | (let ((saved-var (cadr env)) 40 | (saved-env (cadddr env))) 41 | (printf " ~a " saved-var) 42 | (display-env-rec saved-env))))) 43 | 44 | 45 | (define display-env 46 | (lambda (env) 47 | (printf "env: ") 48 | (display-env-rec env) 49 | (newline))) 50 | 51 | (display-env e) 52 | 53 | (define report-no-binding-found 54 | (lambda (search-var all) 55 | (display-env all) 56 | (error 'apply-env "No binding for" search-var))) 57 | 58 | (define report-invalid-env 59 | (lambda (env) 60 | (error 'apply-env "Bad environment" env))) 61 | 62 | (define e 63 | (extend-env 'd 6 64 | (extend-env 'y 8 65 | (extend-env 'x 7 66 | (extend-env 'y 14 67 | (empty-env)))))) 68 | 69 | (equal?? (apply-env e 'd) 6) 70 | (equal?? (apply-env e 'y) 8) 71 | (equal?? (apply-env e 'x) 7) 72 | 73 | ;;(apply-env e 'z) -> error 74 | -------------------------------------------------------------------------------- /base/chapter4/mutable-pairs/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | (require "store.scm") 5 | (provide init-env empty-env extend-env apply-env) 6 | 7 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 8 | 9 | ;; init-env : () -> environment 10 | 11 | ;; (init-env) builds an environment in which i is bound to the 12 | ;; expressed value 1, v is bound to the expressed value 5, and x is 13 | ;; bound to the expressed value 10. 14 | 15 | (define init-env 16 | (lambda () 17 | (extend-env 18 | 'i (newref (num-val 1)) 19 | (extend-env 20 | 'v (newref (num-val 5)) 21 | (extend-env 22 | 'x (newref (num-val 10)) 23 | (empty-env)))))) 24 | 25 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 26 | 27 | (define apply-env 28 | (lambda (env search-sym) 29 | (cases environment env 30 | (empty-env () 31 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 32 | (extend-env (bvar bval saved-env) 33 | (if (eqv? search-sym bvar) 34 | bval 35 | (apply-env saved-env search-sym))) 36 | (extend-env-rec* (p-names b-vars p-bodies saved-env) 37 | (cond 38 | ((location search-sym p-names) 39 | => (lambda (n) 40 | (newref 41 | (proc-val 42 | (procedure 43 | (list-ref b-vars n) 44 | (list-ref p-bodies n) 45 | env))))) 46 | (else (apply-env saved-env search-sym))))))) 47 | 48 | 49 | (define location 50 | (lambda (sym syms) 51 | (cond 52 | ((null? syms) #f) 53 | ((eqv? sym (car syms)) 0) 54 | ((location sym (cdr syms)) 55 | => (lambda (n) 56 | (+ n 1))) 57 | (else #f)))) 58 | 59 | 60 | ) 61 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/tests.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;; 2 | 3 | (define test-list 4 | '( 5 | 6 | ;; simple arithmetic 7 | (positive-const "11" 11) 8 | (negative-const "-33" -33) 9 | (simple-arith-1 "-(44,33)" 11) 10 | 11 | ;; nested arithmetic 12 | (nested-arith-left "-(-(44,33),22)" -11) 13 | (nested-arith-right "-(55, -(22,11))" 44) 14 | 15 | ;; simple variables 16 | (test-var-1 "x" 10) 17 | (test-var-2 "-(x,1)" 9) 18 | (test-var-3 "-(1,x)" -9) 19 | 20 | ;; simple unbound variables 21 | (test-unbound-var-1 "foo" error) 22 | (test-unbound-var-2 "-(x,foo)" error) 23 | 24 | ;; simple conditionals 25 | (if-true "if zero?(0) then 3 else 4" 3) 26 | (if-false "if zero?(1) then 3 else 4" 4) 27 | 28 | ;; test dynamic typechecking 29 | (no-bool-to-diff-1 "-(zero?(0),1)" error) 30 | (no-bool-to-diff-2 "-(1,zero?(0))" error) 31 | (no-int-to-if "if 1 then 2 else 3" error) 32 | 33 | ;; make sure that the test and both arms get evaluated 34 | ;; properly. 35 | (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3) 36 | (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4) 37 | 38 | ;; and make sure the other arm doesn't get evaluated. 39 | (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3) 40 | (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4) 41 | 42 | ;; simple let 43 | (simple-let-1 "let x = 3 in x" 3) 44 | 45 | ;; make sure the body and rhs get evaluated 46 | (eval-let-body "let x = 3 in -(x,1)" 2) 47 | (eval-let-rhs "let x = -(4,1) in -(x,1)" 2) 48 | 49 | ;; check nested let and shadowing 50 | (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1) 51 | (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4) 52 | (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2) 53 | 54 | )) 55 | -------------------------------------------------------------------------------- /base/chapter5/letrec-lang/top-interp-registers.scm: -------------------------------------------------------------------------------- 1 | (module top-interp-registers (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp-registers.scm") ; or use register version. 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 15 | 16 | ;; run : String -> ExpVal 17 | 18 | (define run 19 | (lambda (string) 20 | (value-of-program (scan&parse string)))) 21 | 22 | ;; run-all : () -> Unspecified 23 | 24 | ;; runs all the tests in test-list, comparing the results with 25 | ;; equal-answer? 26 | 27 | (define run-all 28 | (lambda () 29 | (run-tests! run equal-answer? test-list))) 30 | 31 | (define equal-answer? 32 | (lambda (ans correct-ans) 33 | (equal? ans (sloppy->expval correct-ans)))) 34 | 35 | (define sloppy->expval 36 | (lambda (sloppy-val) 37 | (cond 38 | ((number? sloppy-val) (num-val sloppy-val)) 39 | ((boolean? sloppy-val) (bool-val sloppy-val)) 40 | (else 41 | (eopl:error 'sloppy->expval 42 | "Can't convert sloppy value to expval: ~s" 43 | sloppy-val))))) 44 | 45 | ;; run-one : Symbol -> ExpVal 46 | 47 | ;; (run-one sym) runs the test whose name is sym 48 | 49 | (define run-one 50 | (lambda (test-name) 51 | (let ((the-test (assoc test-name test-list))) 52 | (cond 53 | ((assoc test-name test-list) 54 | => (lambda (test) 55 | (run (cadr test)))) 56 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 57 | 58 | ;; (run-all) 59 | 60 | ) 61 | 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /base/chapter3/letrec-lang/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | ;; data structures for letrec-lang. 4 | 5 | (require "lang.scm") ; for expression? 6 | 7 | (provide (all-defined)) ; too many things to list 8 | 9 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 10 | 11 | ;;; an expressed value is either a number, a boolean or a procval. 12 | 13 | (define-datatype expval expval? 14 | (num-val 15 | (value number?)) 16 | (bool-val 17 | (boolean boolean?)) 18 | (proc-val 19 | (proc proc?))) 20 | 21 | ;;; extractors: 22 | 23 | ;; expval->num : ExpVal -> Int 24 | (define expval->num 25 | (lambda (v) 26 | (cases expval v 27 | (num-val (num) num) 28 | (else (expval-extractor-error 'num v))))) 29 | 30 | ;; expval->bool : ExpVal -> Bool 31 | (define expval->bool 32 | (lambda (v) 33 | (cases expval v 34 | (bool-val (bool) bool) 35 | (else (expval-extractor-error 'bool v))))) 36 | 37 | ;; expval->proc : ExpVal -> Proc 38 | (define expval->proc 39 | (lambda (v) 40 | (cases expval v 41 | (proc-val (proc) proc) 42 | (else (expval-extractor-error 'proc v))))) 43 | 44 | (define expval-extractor-error 45 | (lambda (variant value) 46 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 47 | variant value))) 48 | 49 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 50 | 51 | ;; proc? : SchemeVal -> Bool 52 | ;; procedure : Var * Exp * Env -> Proc 53 | (define-datatype proc proc? 54 | (procedure 55 | (bvar symbol?) 56 | (body expression?) 57 | (env environment?))) 58 | 59 | ;; Page: 86 60 | (define-datatype environment environment? 61 | (empty-env) 62 | (extend-env 63 | (bvar symbol?) 64 | (bval expval?) 65 | (saved-env environment?)) 66 | (extend-env-rec 67 | (id symbol?) 68 | (bvar symbol?) 69 | (body expression?) 70 | (saved-env environment?))) 71 | 72 | ) -------------------------------------------------------------------------------- /base/chapter9/classes/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide run run-all) 13 | 14 | 15 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 16 | 17 | ;; run : String -> ExpVal 18 | 19 | (define run 20 | (lambda (string) 21 | (value-of-program (scan&parse string)))) 22 | 23 | ;; run-all : () -> Unspecified 24 | 25 | ;; runs all the tests in test-list, comparing the results with 26 | ;; equal-answer? 27 | 28 | (define run-all 29 | (lambda () 30 | (run-tests! run equal-answer? test-list))) 31 | 32 | (define equal-answer? 33 | (lambda (ans correct-ans) 34 | (equal? ans (sloppy->expval correct-ans)))) 35 | 36 | (define sloppy->expval 37 | (lambda (sloppy-val) 38 | (cond 39 | ((number? sloppy-val) (num-val sloppy-val)) 40 | ((boolean? sloppy-val) (bool-val sloppy-val)) 41 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 42 | (else 43 | (eopl:error 'sloppy->expval 44 | "Can't convert sloppy value to expval: ~s" 45 | sloppy-val))))) 46 | 47 | ;; run-one : Sym -> ExpVal 48 | 49 | ;; (run-one sym) runs the test whose name is sym 50 | 51 | (define run-one 52 | (lambda (test-name) 53 | (let ((the-test (assoc test-name test-list))) 54 | (cond 55 | ((assoc test-name test-list) 56 | => (lambda (test) 57 | (run (cadr test)))) 58 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 59 | 60 | ;; (run-all) 61 | 62 | ) 63 | 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /base/chapter3/let-lang/interp.scm: -------------------------------------------------------------------------------- 1 | ;; interpreter for the LET language. The \commentboxes are the 2 | ;; latex code for inserting the rules into the code in the book. 3 | ;; These are too complicated to put here, see the text, sorry. 4 | 5 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 6 | 7 | ;; value-of-program : Program -> ExpVal 8 | ;; Page: 71 9 | (define value-of-program 10 | (lambda (pgm) 11 | (cases program pgm 12 | (a-program (exp1) 13 | (value-of exp1 (init-env)))))) 14 | 15 | ;; value-of : Exp * Env -> ExpVal 16 | ;; Page: 71 17 | (define value-of 18 | (lambda (exp env) 19 | (cases expression exp 20 | 21 | ;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}} 22 | (const-exp (num) (num-val num)) 23 | 24 | ;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})} 25 | (var-exp (var) (apply-env env var)) 26 | 27 | ;\commentbox{\diffspec} 28 | (diff-exp (exp1 exp2) 29 | (let ((val1 (value-of exp1 env)) 30 | (val2 (value-of exp2 env))) 31 | (let ((num1 (expval->num val1)) 32 | (num2 (expval->num val2))) 33 | (num-val 34 | (- num1 num2))))) 35 | 36 | ;\commentbox{\zerotestspec} 37 | (zero?-exp (exp1) 38 | (let ((val1 (value-of exp1 env))) 39 | (let ((num1 (expval->num val1))) 40 | (if (zero? num1) 41 | (bool-val #t) 42 | (bool-val #f))))) 43 | 44 | ;\commentbox{\ma{\theifspec}} 45 | (if-exp (exp1 exp2 exp3) 46 | (let ((val1 (value-of exp1 env))) 47 | (if (expval->bool val1) 48 | (value-of exp2 env) 49 | (value-of exp3 env)))) 50 | 51 | ;\commentbox{\ma{\theletspecsplit}} 52 | (let-exp (var exp1 body) 53 | (let ((val1 (value-of exp1 env))) 54 | (value-of body 55 | (extend-env var val1 env)))) 56 | 57 | ))) 58 | -------------------------------------------------------------------------------- /base/chapter5/letrec-lang/top-interp.scm: -------------------------------------------------------------------------------- 1 | (module top-interp (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | (provide (all-defined)) 13 | (provide (all-from "interp.scm")) 14 | (provide (all-from "lang.scm")) 15 | 16 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 17 | 18 | ;; run : String -> ExpVal 19 | 20 | (define run 21 | (lambda (string) 22 | (value-of-program (scan&parse string)))) 23 | 24 | ;; run-all : () -> Unspecified 25 | 26 | ;; runs all the tests in test-list, comparing the results with 27 | ;; equal-answer? 28 | 29 | (define run-all 30 | (lambda () 31 | (run-tests! run equal-answer? test-list))) 32 | 33 | (define equal-answer? 34 | (lambda (ans correct-ans) 35 | (equal? ans (sloppy->expval correct-ans)))) 36 | 37 | (define sloppy->expval 38 | (lambda (sloppy-val) 39 | (cond 40 | ((number? sloppy-val) (num-val sloppy-val)) 41 | ((boolean? sloppy-val) (bool-val sloppy-val)) 42 | (else 43 | (eopl:error 'sloppy->expval 44 | "Can't convert sloppy value to expval: ~s" 45 | sloppy-val))))) 46 | 47 | ;; run-one : Sym -> ExpVal 48 | 49 | ;; (run-one sym) runs the test whose name is sym 50 | 51 | (define run-one 52 | (lambda (test-name) 53 | (let ((the-test (assoc test-name test-list))) 54 | (cond 55 | ((assoc test-name test-list) 56 | => (lambda (test) 57 | (run (cadr test)))) 58 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 59 | 60 | ;; (run-all) 61 | 62 | ) 63 | 64 | 65 | -------------------------------------------------------------------------------- /ch7/base/equal-type.scm: -------------------------------------------------------------------------------- 1 | (define equal-types? 2 | (lambda (ty1 ty2) 3 | (equal-up-to-gensyms? ty1 ty2))) 4 | 5 | ;; S-exp = Sym | Listof(S-exp) 6 | ;; A-list = Listof(Pair(TvarTypeSym, TvarTypesym)) 7 | ;; a tvar-type-sym is a symbol ending with a digit. 8 | 9 | ;; equal-up-to-gensyms? : S-exp * S-exp -> Bool 10 | (define equal-up-to-gensyms? 11 | (lambda (sexp1 sexp2) 12 | (equal? 13 | (apply-subst-to-sexp (canonical-subst sexp1) sexp1) 14 | (apply-subst-to-sexp (canonical-subst sexp2) sexp2)))) 15 | 16 | 17 | ;; canonicalize : S-exp -> A-list 18 | ;; usage: replaces all tvar-syms with tvar1, tvar2, etc. 19 | (define canonical-subst 20 | (lambda (sexp) 21 | ;; loop : sexp * alist -> alist 22 | (let loop ((sexp sexp) (table '())) 23 | (cond 24 | ((null? sexp) table) 25 | ((tvar-type-sym? sexp) 26 | (cond 27 | ((assq sexp table) ; sexp is already bound, no more to 28 | ; do 29 | table) 30 | (else 31 | (cons 32 | ;; the length of the table serves as a counter! 33 | (cons sexp (ctr->ty (length table))) 34 | table)))) 35 | ((pair? sexp) 36 | (loop (cdr sexp) 37 | (loop (car sexp) table))) 38 | (else table))))) 39 | 40 | ;; tvar-type-sym? : Sym -> Bool 41 | (define tvar-type-sym? 42 | (lambda (sym) 43 | (and (symbol? sym) 44 | (char-numeric? (car (reverse (symbol->list sym))))))) 45 | 46 | ;; symbol->list : Sym -> List 47 | (define symbol->list 48 | (lambda (x) (string->list (symbol->string x)))) 49 | 50 | 51 | ;; apply-subst-to-sexp : A-list * S-exp -> S-exp 52 | (define apply-subst-to-sexp 53 | (lambda (subst sexp) 54 | (cond 55 | ((null? sexp) sexp) 56 | ((tvar-type-sym? sexp) 57 | (cdr (assq sexp subst))) 58 | ((pair? sexp) 59 | (cons 60 | (apply-subst-to-sexp subst (car sexp)) 61 | (apply-subst-to-sexp subst (cdr sexp)))) 62 | (else sexp)))) 63 | 64 | ;; ctr->ty : N -> Sym 65 | (define ctr->ty 66 | (lambda (n) 67 | (string->symbol 68 | (string-append 69 | "tvar" 70 | (number->string n))))) 71 | -------------------------------------------------------------------------------- /ch8/base/equal-type.scm: -------------------------------------------------------------------------------- 1 | (define equal-types? 2 | (lambda (ty1 ty2) 3 | (equal-up-to-gensyms? ty1 ty2))) 4 | 5 | ;; S-exp = Sym | Listof(S-exp) 6 | ;; A-list = Listof(Pair(TvarTypeSym, TvarTypesym)) 7 | ;; a tvar-type-sym is a symbol ending with a digit. 8 | 9 | ;; equal-up-to-gensyms? : S-exp * S-exp -> Bool 10 | (define equal-up-to-gensyms? 11 | (lambda (sexp1 sexp2) 12 | (equal? 13 | (apply-subst-to-sexp (canonical-subst sexp1) sexp1) 14 | (apply-subst-to-sexp (canonical-subst sexp2) sexp2)))) 15 | 16 | 17 | ;; canonicalize : S-exp -> A-list 18 | ;; usage: replaces all tvar-syms with tvar1, tvar2, etc. 19 | (define canonical-subst 20 | (lambda (sexp) 21 | ;; loop : sexp * alist -> alist 22 | (let loop ((sexp sexp) (table '())) 23 | (cond 24 | ((null? sexp) table) 25 | ((tvar-type-sym? sexp) 26 | (cond 27 | ((assq sexp table) ; sexp is already bound, no more to 28 | ; do 29 | table) 30 | (else 31 | (cons 32 | ;; the length of the table serves as a counter! 33 | (cons sexp (ctr->ty (length table))) 34 | table)))) 35 | ((pair? sexp) 36 | (loop (cdr sexp) 37 | (loop (car sexp) table))) 38 | (else table))))) 39 | 40 | ;; tvar-type-sym? : Sym -> Bool 41 | (define tvar-type-sym? 42 | (lambda (sym) 43 | (and (symbol? sym) 44 | (char-numeric? (car (reverse (symbol->list sym))))))) 45 | 46 | ;; symbol->list : Sym -> List 47 | (define symbol->list 48 | (lambda (x) (string->list (symbol->string x)))) 49 | 50 | 51 | ;; apply-subst-to-sexp : A-list * S-exp -> S-exp 52 | (define apply-subst-to-sexp 53 | (lambda (subst sexp) 54 | (cond 55 | ((null? sexp) sexp) 56 | ((tvar-type-sym? sexp) 57 | (cdr (assq sexp subst))) 58 | ((pair? sexp) 59 | (cons 60 | (apply-subst-to-sexp subst (car sexp)) 61 | (apply-subst-to-sexp subst (cdr sexp)))) 62 | (else sexp)))) 63 | 64 | ;; ctr->ty : N -> Sym 65 | (define ctr->ty 66 | (lambda (n) 67 | (string->symbol 68 | (string-append 69 | "tvar" 70 | (number->string n))))) 71 | -------------------------------------------------------------------------------- /ch2/16.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; var-exp : Var -> Lc-exp 4 | (define var-exp 5 | (lambda (var) 6 | `(var-exp ,var))) 7 | 8 | ;; lambda-exp : Var * Lc-exp -> Lc-exp 9 | (define lambda-exp 10 | (lambda (var lc-exp) 11 | `(lambda-exp ,var ,lc-exp))) 12 | 13 | ;; app-exp : Lc-exp * Lc-exp -> Lc-exp 14 | (define app-exp 15 | (lambda (lc-exp1 lc-exp2) 16 | `(app-exp ,lc-exp1 ,lc-exp2))) 17 | 18 | ;; var-exp? : Lc-exp -> Bool 19 | (define var-exp? 20 | (lambda (x) 21 | (and (pair? x) (eq? (car x) 'var-exp)))) 22 | 23 | ;; lambda-exp? : Lc-exp -> Bool 24 | (define lambda-exp? 25 | (lambda (x) 26 | (and (pair? x) (eq? (car x) 'lambda-exp)))) 27 | 28 | ;; app-exp? : Lc-exp -> Bool 29 | (define app-exp? 30 | (lambda (x) 31 | (and (pair? x) (eq? (car x) 'app-exp)))) 32 | 33 | ;; var-exp->var : Lc-exp -> Var 34 | (define var-exp->var 35 | (lambda (x) 36 | (cadr x))) 37 | 38 | ;; lambda-exp->bound-var : Lc-exp -> Var 39 | (define lambda-exp->bound-var 40 | (lambda (x) 41 | (cadr x))) 42 | 43 | ;; lambda-exp->body : Lc-exp -> Lc-exp 44 | (define lambda-exp->body 45 | (lambda (x) 46 | (caddr x))) 47 | 48 | ;; app-exp->rator : Lc-exp -> Lc-exp 49 | (define app-exp->rator 50 | (lambda (x) 51 | (cadr x))) 52 | 53 | ;; app-exp->rand : Lc-exp -> Lc-exp 54 | (define app-exp->rand 55 | (lambda (x) 56 | (caddr x))) 57 | 58 | ;; occurs-free? : Sym * Lcexp -> Bool 59 | (define occurs-free? 60 | (lambda (search-var exp) 61 | (cond 62 | ((var-exp? exp) (eqv? search-var (var-exp->var exp))) 63 | ((lambda-exp? exp) 64 | (and 65 | (not (eqv? search-var (lambda-exp->bound-var exp))) 66 | (occurs-free? search-var (lambda-exp->body exp)))) 67 | (else 68 | (or 69 | (occurs-free? search-var (app-exp->rator exp)) 70 | (occurs-free? search-var (app-exp->rand exp))))))) 71 | 72 | (equal?? 73 | (occurs-free? 'a (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a)))) 74 | #f) 75 | 76 | (equal?? 77 | (occurs-free? 'b (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a)))) 78 | #t) 79 | -------------------------------------------------------------------------------- /ch2/15.scm: -------------------------------------------------------------------------------- 1 | (load "../libs/init.scm") 2 | 3 | ;; var-exp : Var -> Lc-exp 4 | (define var-exp 5 | (lambda (var) 6 | (cons 'var-exp var))) 7 | 8 | ;; lambda-exp : Var * Lc-exp -> Lc-exp 9 | (define lambda-exp 10 | (lambda (var lc-exp) 11 | (list 'lambda-exp (list var) lc-exp))) 12 | 13 | ;; app-exp : Lc-exp * Lc-exp -> Lc-exp 14 | (define app-exp 15 | (lambda (lc-exp1 lc-exp2) 16 | (list 'app-exp lc-exp1 lc-exp2))) 17 | 18 | ;; var-exp? : Lc-exp -> Bool 19 | (define var-exp? 20 | (lambda (x) 21 | (and (pair? x) (eq? (car x) 'var-exp)))) 22 | 23 | ;; lambda-exp? : Lc-exp -> Bool 24 | (define lambda-exp? 25 | (lambda (x) 26 | (and (pair? x) (eq? (car x) 'lambda-exp)))) 27 | 28 | ;; app-exp? : Lc-exp -> Bool 29 | (define app-exp? 30 | (lambda (x) 31 | (and (list? x) (eq? (car x) 'app-exp)))) 32 | 33 | ;; var-exp->var : Lc-exp -> Var 34 | (define var-exp->var 35 | (lambda (x) 36 | (cdr x))) 37 | 38 | ;; lambda-exp->bound-var : Lc-exp -> Var 39 | (define lambda-exp->bound-var 40 | (lambda (x) 41 | (caadr x))) 42 | 43 | ;; lambda-exp->body : Lc-exp -> Lc-exp 44 | (define lambda-exp->body 45 | (lambda (x) 46 | (caddr x))) 47 | 48 | ;; app-exp->rator : Lc-exp -> Lc-exp 49 | (define app-exp->rator 50 | (lambda (x) 51 | (cadr x))) 52 | 53 | ;; app-exp->rand : Lc-exp -> Lc-exp 54 | (define app-exp->rand 55 | (lambda (x) 56 | (caddr x))) 57 | 58 | ;; occurs-free? : Sym * Lcexp -> Bool 59 | (define occurs-free? 60 | (lambda (search-var exp) 61 | (cond 62 | ((var-exp? exp) (eqv? search-var (var-exp->var exp))) 63 | ((lambda-exp? exp) 64 | (and 65 | (not (eqv? search-var (lambda-exp->bound-var exp))) 66 | (occurs-free? search-var (lambda-exp->body exp)))) 67 | (else 68 | (or 69 | (occurs-free? search-var (app-exp->rator exp)) 70 | (occurs-free? search-var (app-exp->rand exp))))))) 71 | 72 | (equal?? 73 | (occurs-free? 'a (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a)))) 74 | #f) 75 | 76 | (equal?? 77 | (occurs-free? 'b (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a)))) 78 | #t) 79 | -------------------------------------------------------------------------------- /base/chapter3/lexaddr-lang/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | (require "translator.scm") ; for translation-of-program 12 | 13 | (provide run run-all) 14 | 15 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 16 | 17 | ;; run : String -> ExpVal 18 | ;; Page: 98 19 | (define run 20 | (lambda (string) 21 | (value-of-translation 22 | (translation-of-program 23 | (scan&parse string))))) 24 | 25 | ;; run-all : () -> Unspecified 26 | 27 | ;; runs all the tests in test-list, comparing the results with 28 | ;; equal-answer? 29 | 30 | (define run-all 31 | (lambda () 32 | (run-tests! run equal-answer? test-list))) 33 | 34 | (define equal-answer? 35 | (lambda (ans correct-ans) 36 | (equal? ans (sloppy->expval correct-ans)))) 37 | 38 | (define sloppy->expval 39 | (lambda (sloppy-val) 40 | (cond 41 | ((number? sloppy-val) (num-val sloppy-val)) 42 | ((boolean? sloppy-val) (bool-val sloppy-val)) 43 | (else 44 | (eopl:error 'sloppy->expval 45 | "Can't convert sloppy value to expval: ~s" 46 | sloppy-val))))) 47 | 48 | ;; run-one : Sym -> ExpVal 49 | 50 | ;; (run-one sym) runs the test whose name is sym 51 | 52 | (define run-one 53 | (lambda (test-name) 54 | (let ((the-test (assoc test-name test-list))) 55 | (cond 56 | ((assoc test-name test-list) 57 | => (lambda (test) 58 | (run (cadr test)))) 59 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 60 | 61 | ;; (run-all) 62 | 63 | ) 64 | 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /base/chapter3/letrec-lang/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | (require "interp.scm") ; for value-of-program 10 | (require "tests.scm") ; for test-list 11 | 12 | ;; since this is the top-level module, we don't really need to 13 | ;; provide anything, but we do so just in case. 14 | 15 | (provide run run-all) 16 | 17 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 18 | 19 | ;; run : String -> ExpVal 20 | (define run 21 | (lambda (string) 22 | (value-of-program (scan&parse string)))) 23 | 24 | ;; run-all : () -> Unspecified 25 | 26 | ;; runs all the tests in test-list, comparing the results with 27 | ;; equal-answer? 28 | 29 | (define run-all 30 | (lambda () 31 | (run-tests! run equal-answer? test-list))) 32 | 33 | (define equal-answer? 34 | (lambda (ans correct-ans) 35 | (equal? ans (sloppy->expval correct-ans)))) 36 | 37 | (define sloppy->expval 38 | (lambda (sloppy-val) 39 | (cond 40 | ((number? sloppy-val) (num-val sloppy-val)) 41 | ((boolean? sloppy-val) (bool-val sloppy-val)) 42 | (else 43 | (eopl:error 'sloppy->expval 44 | "Can't convert sloppy value to expval: ~s" 45 | sloppy-val))))) 46 | 47 | ;; run-one : Sym -> ExpVal 48 | 49 | ;; (run-one sym) runs the test whose name is sym 50 | 51 | (define run-one 52 | (lambda (test-name) 53 | (let ((the-test (assoc test-name test-list))) 54 | (cond 55 | ((assoc test-name test-list) 56 | => (lambda (test) 57 | (run (cadr test)))) 58 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 59 | 60 | ;; (run-all) 61 | 62 | ) 63 | 64 | 65 | 66 | 67 | -------------------------------------------------------------------------------- /base/chapter3/letrec-lang/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; grammar for the LETREC language 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined)) 8 | 9 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 10 | 11 | (define the-lexical-spec 12 | '((whitespace (whitespace) skip) 13 | (comment ("%" (arbno (not #\newline))) skip) 14 | (identifier 15 | (letter (arbno (or letter digit "_" "-" "?"))) 16 | symbol) 17 | (number (digit (arbno digit)) number) 18 | (number ("-" digit (arbno digit)) number) 19 | )) 20 | 21 | (define the-grammar 22 | '((program (expression) a-program) 23 | 24 | (expression (number) const-exp) 25 | (expression 26 | ("-" "(" expression "," expression ")") 27 | diff-exp) 28 | 29 | (expression 30 | ("zero?" "(" expression ")") 31 | zero?-exp) 32 | 33 | (expression 34 | ("if" expression "then" expression "else" expression) 35 | if-exp) 36 | 37 | (expression (identifier) var-exp) 38 | 39 | (expression 40 | ("let" identifier "=" expression "in" expression) 41 | let-exp) 42 | 43 | (expression 44 | ("proc" "(" identifier ")" expression) 45 | proc-exp) 46 | 47 | (expression 48 | ("(" expression expression ")") 49 | call-exp) 50 | 51 | (expression 52 | ("letrec" 53 | identifier "(" identifier ")" "=" expression 54 | "in" expression) 55 | letrec-exp) 56 | 57 | )) 58 | 59 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 60 | 61 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 62 | 63 | (define show-the-datatypes 64 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 65 | 66 | (define scan&parse 67 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 68 | 69 | (define just-scan 70 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 71 | 72 | ) 73 | -------------------------------------------------------------------------------- /base/chapter5/letrec-lang/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; grammar for the LETREC language 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined)) 8 | 9 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 10 | 11 | (define the-lexical-spec 12 | '((whitespace (whitespace) skip) 13 | (comment ("%" (arbno (not #\newline))) skip) 14 | (identifier 15 | (letter (arbno (or letter digit "_" "-" "?"))) 16 | symbol) 17 | (number (digit (arbno digit)) number) 18 | (number ("-" digit (arbno digit)) number) 19 | )) 20 | 21 | (define the-grammar 22 | '((program (expression) a-program) 23 | 24 | (expression (number) const-exp) 25 | (expression 26 | ("-" "(" expression "," expression ")") 27 | diff-exp) 28 | 29 | (expression 30 | ("zero?" "(" expression ")") 31 | zero?-exp) 32 | 33 | (expression 34 | ("if" expression "then" expression "else" expression) 35 | if-exp) 36 | 37 | (expression (identifier) var-exp) 38 | 39 | (expression 40 | ("let" identifier "=" expression "in" expression) 41 | let-exp) 42 | 43 | (expression 44 | ("proc" "(" identifier ")" expression) 45 | proc-exp) 46 | 47 | (expression 48 | ("(" expression expression ")") 49 | call-exp) 50 | 51 | (expression 52 | ("letrec" 53 | identifier "(" identifier ")" "=" expression 54 | "in" expression) 55 | letrec-exp) 56 | 57 | )) 58 | 59 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 60 | 61 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 62 | 63 | (define show-the-datatypes 64 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 65 | 66 | (define scan&parse 67 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 68 | 69 | (define just-scan 70 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 71 | 72 | ) 73 | -------------------------------------------------------------------------------- /base/chapter5/thread-lang/semaphores.scm: -------------------------------------------------------------------------------- 1 | (module semaphores (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") ; for store ops 5 | (require "data-structures.scm") ; for lock, a-lock 6 | (require "scheduler.scm") ; for os calls 7 | (require "queues.scm") 8 | 9 | (provide (all-defined)) 10 | 11 | ;; implements binary semaphores (mutexes). 12 | 13 | (define instrument-mutexes (make-parameter #f)) 14 | 15 | ;; new-mutex () -> Mutex 16 | ;; Page: 188 17 | (define new-mutex 18 | (lambda () 19 | (a-mutex 20 | (newref #f) 21 | (newref '())))) 22 | 23 | ; wait queue, initially empty 24 | 25 | ;; wait-for-mutex : Mutex * Thread -> FinalAnswer 26 | ;; waits for mutex to be open, then closes it. 27 | ;; Page: 190 28 | (define wait-for-mutex 29 | (lambda (m th) 30 | (cases mutex m 31 | (a-mutex (ref-to-closed? ref-to-wait-queue) 32 | (cond 33 | ((deref ref-to-closed?) 34 | (setref! ref-to-wait-queue 35 | (enqueue (deref ref-to-wait-queue) th)) 36 | (run-next-thread)) 37 | (else 38 | (setref! ref-to-closed? #t) 39 | (th))))))) 40 | 41 | ;; signal-mutex : Mutex * Thread -> FinalAnswer 42 | ;; Page 190 43 | (define signal-mutex 44 | (lambda (m th) 45 | (cases mutex m 46 | (a-mutex (ref-to-closed? ref-to-wait-queue) 47 | (let ((closed? (deref ref-to-closed?)) 48 | (wait-queue (deref ref-to-wait-queue))) 49 | (if closed? 50 | (if (empty? wait-queue) 51 | (setref! ref-to-closed? #f) 52 | (dequeue wait-queue 53 | (lambda (first-waiting-th other-waiting-ths) 54 | (place-on-ready-queue! 55 | first-waiting-th) 56 | (setref! 57 | ref-to-wait-queue 58 | other-waiting-ths))))) 59 | (th)))))) 60 | 61 | ) -------------------------------------------------------------------------------- /ch3/base/environments.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; builds environment interface, using data structures defined in 3 | ;; data-structures.scm. 4 | 5 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 6 | 7 | ;; init-env : () -> Env 8 | ;; usage: (init-env) = [i=1, v=5, x=10] 9 | ;; (init-env) builds an environment in which i is bound to the 10 | ;; expressed value 1, v is bound to the expressed value 5, and x is 11 | ;; bound to the expressed value 10. 12 | ;; Page: 69 13 | 14 | (define empty-env-record 15 | (lambda () 16 | '())) 17 | 18 | (define extended-env-record 19 | (lambda (sym val old-env) 20 | (cons (list sym val) old-env))) 21 | 22 | (define empty-env-record? null?) 23 | 24 | (define environment? 25 | (lambda (x) 26 | (or (empty-env-record? x) 27 | (and (pair? x) 28 | (symbol? (car (car x))) 29 | (expval? (cadr (car x))) 30 | (environment? (cdr x)))))) 31 | 32 | (define extended-env-record->sym 33 | (lambda (r) 34 | (car (car r)))) 35 | 36 | (define extended-env-record->val 37 | (lambda (r) 38 | (cadr (car r)))) 39 | 40 | (define extended-env-record->old-env 41 | (lambda (r) 42 | (cdr r))) 43 | 44 | (define init-env 45 | (lambda () 46 | (extend-env 47 | 'i (num-val 1) 48 | (extend-env 49 | 'v (num-val 5) 50 | (extend-env 51 | 'x (num-val 10) 52 | (empty-env)))))) 53 | 54 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 55 | 56 | (define empty-env 57 | (lambda () 58 | (empty-env-record))) 59 | 60 | (define empty-env? 61 | (lambda (x) 62 | (empty-env-record? x))) 63 | 64 | (define extend-env 65 | (lambda (sym val old-env) 66 | (extended-env-record sym val old-env))) 67 | 68 | (define apply-env 69 | (lambda (env search-sym) 70 | (if (empty-env? env) 71 | (error 'apply-env "No binding for ~s" search-sym) 72 | (let ((sym (extended-env-record->sym env)) 73 | (val (extended-env-record->val env)) 74 | (old-env (extended-env-record->old-env env))) 75 | (if (eqv? search-sym sym) 76 | val 77 | (apply-env old-env search-sym)))))) 78 | -------------------------------------------------------------------------------- /ch6/30.scm: -------------------------------------------------------------------------------- 1 | 2 | (load-relative "../libs/init.scm") 3 | (load-relative "./base/test.scm") 4 | (load-relative "./base/cps.scm") 5 | (load-relative "./base/data-structures.scm") 6 | (load-relative "./base/cps-cases.scm") 7 | (load-relative "./base/cps-lang.scm") 8 | (load-relative "./base/base-iterp.scm") 9 | 10 | ;; cps-of-exp/ctx : InpExp × (SimpleExp → TfExp) → TfExp 11 | (define cps-of-exp/ctx 12 | (lambda (exp context) 13 | (if (inp-exp-simple? exp) 14 | (context (cps-of-simple-exp exp)) 15 | (let ((var (fresh-identifier 'var))) 16 | (cps-of-exp exp 17 | (cps-proc-exp (list var) 18 | (context (cps-var-exp var)))))))) 19 | 20 | 21 | (define cps-of-diff-exp 22 | (lambda (exp1 exp2 k-exp) 23 | (cps-of-exp/ctx exp1 24 | (lambda (simp1) 25 | (cps-of-exp/ctx exp2 26 | (lambda (simp2) 27 | (make-send-to-cont k-exp 28 | (cps-diff-exp simp1 simp2)))))))) 29 | 30 | ;; cps-of-zero?-exp : InpExp * SimpleExp -> TfExp 31 | (define cps-of-zero?-exp 32 | (lambda (exp1 k-exp) 33 | (cps-of-exp/ctx exp1 34 | (lambda (simp1) 35 | (make-send-to-cont 36 | k-exp 37 | (cps-zero?-exp simp1)))))) 38 | 39 | ;; cps-of-if-exp : InpExp * InpExp * InpExp * SimpleExp -> TfExp 40 | (define cps-of-if-exp 41 | (lambda (exp1 exp2 exp3 k-exp) 42 | (cps-of-exp/ctx exp1 43 | (lambda (simp1) 44 | (cps-if-exp simp1 45 | (cps-of-exp exp2 k-exp) 46 | (cps-of-exp exp3 k-exp)))))) 47 | 48 | ;; cps-of-sum-exp : Listof (InpExp) * SimpleExp -> TfExp 49 | ;; keep the same 50 | (define cps-of-sum-exp 51 | (lambda (exps k-exp) 52 | (cps-of-exps exps 53 | (lambda (simp1) 54 | (make-send-to-cont 55 | k-exp 56 | (cps-sum-exp simp1)))))) 57 | 58 | ;; cps-of-call-exp : InpExp * Listof(InpExp) * SimpleExp -> TfExp 59 | (define cps-of-call-exp 60 | (lambda (rator rands k-exp) 61 | (cps-of-exps (cons rator rands) 62 | (lambda (new-rands) 63 | (cps-call-exp 64 | (car new-rands) 65 | (append (cdr new-rands) (list k-exp))))))) 66 | 67 | (run-all) 68 | -------------------------------------------------------------------------------- /base/chapter4/explicit-refs/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | (provide init-env empty-env extend-env apply-env) 5 | 6 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 7 | 8 | 9 | ;; init-env : () -> Env 10 | ;; usage: (init-env) = [i=1, v=5, x=10] 11 | ;; (init-env) builds an environment in which i is bound to the 12 | ;; expressed value 1, v is bound to the expressed value 5, and x is 13 | ;; bound to the expressed value 10. 14 | ;; Page: 69 15 | (define init-env 16 | (lambda () 17 | (extend-env 18 | 'i (num-val 1) 19 | (extend-env 20 | 'v (num-val 5) 21 | (extend-env 22 | 'x (num-val 10) 23 | (empty-env)))))) 24 | 25 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 26 | 27 | (define apply-env 28 | (lambda (env search-sym) 29 | (cases environment env 30 | (empty-env () 31 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 32 | (extend-env (bvar bval saved-env) 33 | (if (eqv? search-sym bvar) 34 | bval 35 | (apply-env saved-env search-sym))) 36 | (extend-env-rec* (p-names b-vars p-bodies saved-env) 37 | (cond 38 | ((location search-sym p-names) 39 | => (lambda (n) 40 | (proc-val 41 | (procedure 42 | (list-ref b-vars n) 43 | (list-ref p-bodies n) 44 | env)))) 45 | (else (apply-env saved-env search-sym))))))) 46 | 47 | ;; location : Sym * Listof(Sym) -> Maybe(Int) 48 | ;; (location sym syms) returns the location of sym in syms or #f is 49 | ;; sym is not in syms. We can specify this as follows: 50 | ;; if (memv sym syms) 51 | ;; then (list-ref syms (location sym syms)) = sym 52 | ;; else (location sym syms) = #f 53 | (define location 54 | (lambda (sym syms) 55 | (cond 56 | ((null? syms) #f) 57 | ((eqv? sym (car syms)) 0) 58 | ((location sym (cdr syms)) 59 | => (lambda (n) 60 | (+ n 1))) 61 | (else #f)))) 62 | 63 | ) -------------------------------------------------------------------------------- /base/chapter5/exceptions/top.scm: -------------------------------------------------------------------------------- 1 | (module top (lib "eopl.ss" "eopl") 2 | 3 | ;; top level module. Loads all required pieces. 4 | ;; Run the test suite with (run-all). 5 | 6 | (require "drscheme-init.scm") 7 | (require "data-structures.scm") ; for expval constructors 8 | (require "lang.scm") ; for scan&parse 9 | 10 | (require "interp.scm") 11 | 12 | (require "tests.scm") ; for test-list 13 | 14 | 15 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 16 | 17 | ;; run : String -> ExpVal 18 | 19 | (define run 20 | (lambda (string) 21 | (value-of-program (scan&parse string)))) 22 | 23 | ;; run-all : () -> Unspecified 24 | 25 | ;; runs all the tests in test-list, comparing the results with 26 | ;; equal-answer? 27 | 28 | (define run-all 29 | (lambda () 30 | (run-tests! run equal-answer? test-list))) 31 | 32 | (define equal-answer? 33 | (lambda (ans correct-ans) 34 | (equal? ans (sloppy->expval correct-ans)))) 35 | 36 | (define sloppy->expval 37 | (lambda (sloppy-val) 38 | (cond 39 | ((number? sloppy-val) (num-val sloppy-val)) 40 | ((boolean? sloppy-val) (bool-val sloppy-val)) 41 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 42 | (else 43 | (eopl:error 'sloppy->expval 44 | "Can't convert sloppy value to expval: ~s" 45 | sloppy-val))))) 46 | 47 | ;; run-one : Sym -> ExpVal 48 | 49 | ;; (run-one sym) runs the test whose name is sym 50 | 51 | (define run-one 52 | (lambda (test-name) 53 | (let ((the-test (assoc test-name test-list))) 54 | (cond 55 | ((assoc test-name test-list) 56 | => (lambda (test) 57 | (run (cadr test)))) 58 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 59 | 60 | ;; make sure this is initially off. 61 | (trace-apply-procedure #f) 62 | 63 | ;; (run-all) 64 | 65 | ;; to generate the big trace in the text, say 66 | ;; (trace-apply-procedure #t) 67 | ;; (run-one 'text-example-1.2) 68 | 69 | ) 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /ch7/base/data-structures.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 2 | 3 | ;;; an expressed value is either a number, a boolean or a procval. 4 | 5 | 6 | ;;; extractors: 7 | (define expval->num 8 | (lambda (v) 9 | (cases expval v 10 | (num-val (num) num) 11 | (else (expval-extractor-error 'num v))))) 12 | 13 | (define expval->bool 14 | (lambda (v) 15 | (cases expval v 16 | (bool-val (bool) bool) 17 | (else (expval-extractor-error 'bool v))))) 18 | 19 | (define expval->proc 20 | (lambda (v) 21 | (cases expval v 22 | (proc-val (proc) proc) 23 | (else (expval-extractor-error 'proc v))))) 24 | 25 | (define expval-extractor-error 26 | (lambda (variant value) 27 | (error 'expval-extractors "Looking for a ~s, found ~s" 28 | variant value))) 29 | 30 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 31 | (define-datatype proc proc? 32 | (procedure 33 | (bvar symbol?) 34 | (body expression?) 35 | (env environment?))) 36 | 37 | (define-datatype environment environment? 38 | (empty-env) 39 | (extend-env 40 | (bvar symbol?) 41 | (bval expval?) 42 | (saved-env environment?)) 43 | (extend-env-rec 44 | (p-name symbol?) 45 | (b-var symbol?) 46 | (p-body expression?) 47 | (saved-env environment?))) 48 | 49 | 50 | (define init-env 51 | (lambda () 52 | (extend-env 53 | 'i (num-val 1) 54 | (extend-env 55 | 'v (num-val 5) 56 | (extend-env 57 | 'x (num-val 10) 58 | (empty-env)))))) 59 | 60 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 61 | 62 | (define apply-env 63 | (lambda (env search-sym) 64 | (cases environment env 65 | (empty-env () 66 | (error 'apply-env "No binding for ~s" search-sym)) 67 | (extend-env (bvar bval saved-env) 68 | (if (eqv? search-sym bvar) 69 | bval 70 | (apply-env saved-env search-sym))) 71 | (extend-env-rec (p-name b-var p-body saved-env) 72 | (if (eqv? search-sym p-name) 73 | (proc-val (procedure b-var p-body env)) 74 | (apply-env saved-env search-sym)))))) 75 | -------------------------------------------------------------------------------- /base/chapter3/lexaddr-lang/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang 2 | 3 | ;; grammar for the LEXADDR language 4 | 5 | (lib "eopl.ss" "eopl") 6 | 7 | (require "drscheme-init.scm") 8 | 9 | (provide (all-defined)) 10 | 11 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 12 | 13 | (define the-lexical-spec 14 | '((whitespace (whitespace) skip) 15 | (comment ("%" (arbno (not #\newline))) skip) 16 | (identifier 17 | (letter (arbno (or letter digit "_" "-" "?"))) 18 | symbol) 19 | (number (digit (arbno digit)) number) 20 | (number ("-" digit (arbno digit)) number) 21 | )) 22 | 23 | (define the-grammar 24 | '((program (expression) a-program) 25 | 26 | (expression (number) const-exp) 27 | (expression 28 | ("-" "(" expression "," expression ")") 29 | diff-exp) 30 | 31 | (expression 32 | ("zero?" "(" expression ")") 33 | zero?-exp) 34 | 35 | (expression 36 | ("if" expression "then" expression "else" expression) 37 | if-exp) 38 | 39 | (expression (identifier) var-exp) 40 | 41 | (expression 42 | ("let" identifier "=" expression "in" expression) 43 | let-exp) 44 | 45 | (expression 46 | ("proc" "(" identifier ")" expression) 47 | proc-exp) 48 | 49 | (expression 50 | ("(" expression expression ")") 51 | call-exp) 52 | 53 | (expression ("%nameless-var" number) nameless-var-exp) 54 | (expression 55 | ("%let" expression "in" expression) 56 | nameless-let-exp) 57 | (expression 58 | ("%lexproc" expression) 59 | nameless-proc-exp) 60 | 61 | )) 62 | 63 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 64 | 65 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 66 | 67 | (define show-the-datatypes 68 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 69 | 70 | (define scan&parse 71 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 72 | 73 | (define just-scan 74 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 75 | 76 | ) 77 | -------------------------------------------------------------------------------- /ch6/base/cps-in-lang.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 2 | 3 | (define the-lexical-spec 4 | '((whitespace (whitespace) skip) 5 | (comment ("%" (arbno (not #\newline))) skip) 6 | (identifier 7 | (letter (arbno (or letter digit "_" "-" "?"))) 8 | symbol) 9 | (number (digit (arbno digit)) number) 10 | (number ("-" digit (arbno digit)) number) 11 | )) 12 | 13 | (define the-grammar 14 | '((program (expression) a-program) 15 | 16 | (expression (number) const-exp) 17 | 18 | (expression 19 | ("-" "(" expression "," expression ")") 20 | diff-exp) 21 | 22 | (expression 23 | ("+" "(" (separated-list expression ",") ")") 24 | sum-exp) 25 | 26 | (expression 27 | ("zero?" "(" expression ")") 28 | zero?-exp) 29 | 30 | (expression 31 | ("if" expression "then" expression "else" expression) 32 | if-exp) 33 | 34 | (expression 35 | ("letrec" 36 | (arbno identifier "(" (arbno identifier) ")" 37 | "=" expression) 38 | "in" 39 | expression) 40 | letrec-exp) 41 | 42 | (expression (identifier) var-exp) 43 | 44 | (expression 45 | ("let" identifier "=" expression "in" expression) 46 | let-exp) 47 | 48 | (expression 49 | ("proc" "(" (arbno identifier) ")" expression) 50 | proc-exp) 51 | 52 | (expression 53 | ("(" expression (arbno expression) ")") 54 | call-exp) 55 | 56 | (expression 57 | ("print" "(" expression ")") 58 | print-exp) 59 | 60 | (expression 61 | ("newref" "(" expression ")") 62 | newref-exp) 63 | 64 | (expression 65 | ("deref" "(" expression ")") 66 | deref-exp) 67 | 68 | (expression 69 | ("setref" "(" expression "," expression ")") 70 | setref-exp) 71 | 72 | )) 73 | 74 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 75 | 76 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 77 | 78 | (define show-the-datatypes 79 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 80 | 81 | (define scan&parse 82 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 83 | 84 | (define just-scan 85 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 86 | -------------------------------------------------------------------------------- /ch6/base/exception-lang.scm: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 2 | 3 | (define the-lexical-spec 4 | '((whitespace (whitespace) skip) 5 | (comment ("%" (arbno (not #\newline))) skip) 6 | (identifier 7 | (letter (arbno (or letter digit "_" "-" "?"))) 8 | symbol) 9 | (number (digit (arbno digit)) number) 10 | (number ("-" digit (arbno digit)) number) 11 | )) 12 | 13 | (define the-grammar 14 | '((program (expression) a-program) 15 | 16 | (expression (number) const-exp) 17 | 18 | (expression 19 | ("-" "(" expression "," expression ")") 20 | diff-exp) 21 | 22 | (expression 23 | ("if" expression "then" expression "else" expression) 24 | if-exp) 25 | 26 | (expression (identifier) var-exp) 27 | 28 | (expression 29 | ("proc" "(" identifier ")" expression) 30 | proc-exp) 31 | 32 | (expression 33 | ("(" expression expression ")") 34 | call-exp) 35 | 36 | (expression 37 | ("let" identifier "=" expression "in" expression) 38 | let-exp) 39 | 40 | (expression 41 | ("letrec" 42 | identifier "(" identifier ")" "=" expression 43 | "in" expression) 44 | letrec-exp) 45 | 46 | ;; Lists. We will have lists of literal numbers only. 47 | 48 | (expression 49 | ("list" "(" (separated-list number ",") ")") 50 | const-list-exp) 51 | 52 | (expression 53 | (unary-op "(" expression ")") 54 | unop-exp) 55 | 56 | (expression 57 | ("try" expression "catch" "(" identifier ")" expression) 58 | try-exp) 59 | 60 | (expression 61 | ("raise" expression) 62 | raise-exp) 63 | 64 | (unary-op ("null?") null?-unop) 65 | (unary-op ("car") car-unop) 66 | (unary-op ("cdr" ) cdr-unop) 67 | (unary-op ("zero?") zero?-unop) 68 | 69 | )) 70 | 71 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 72 | 73 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 74 | 75 | (define show-the-datatypes 76 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 77 | 78 | (define scan&parse 79 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 80 | 81 | (define just-scan 82 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 83 | -------------------------------------------------------------------------------- /ch8/01.scm: -------------------------------------------------------------------------------- 1 | (load-relative "../libs/init.scm") 2 | (load-relative "./base/test.scm") 3 | (load-relative "./base/equal-type.scm") 4 | (load-relative "./base/data-structures.scm") 5 | (load-relative "./base/cases.scm") 6 | (load-relative "./base/simplemodule-lang.scm") 7 | 8 | (define have-duplicate? 9 | (lambda (defns) 10 | (if (null? defns) 11 | #f 12 | (let ((first-name (module-definition->name (car defns)))) 13 | (if (maybe-lookup-module-in-list first-name (cdr defns)) 14 | #t 15 | (have-duplicate? (cdr defns))))))) 16 | 17 | (define add-module-defns-to-tenv 18 | (lambda (defns tenv) 19 | (if (have-duplicate? defns) 20 | (error 'add-module-defns-to-tenv "have duplicate module names!") 21 | (if (null? defns) 22 | tenv 23 | (cases module-definition (car defns) 24 | (a-module-definition (m-name expected-iface m-body) 25 | (let ((actual-iface (interface-of m-body tenv))) 26 | (if (<:-iface actual-iface expected-iface tenv) 27 | (let ((new-tenv 28 | (extend-tenv-with-module 29 | m-name 30 | expected-iface 31 | tenv))) 32 | (add-module-defns-to-tenv 33 | (cdr defns) new-tenv)) 34 | (report-module-doesnt-satisfy-iface 35 | m-name expected-iface actual-iface))))))))) 36 | 37 | 38 | (run-all) 39 | 40 | 41 | (add-check! '(duplicate-module-name "module m1 interface [v : int] body [v = 4] 42 | module m1 43 | interface [v : int] 44 | body [v = 3] 45 | from m1 take v" error)) 46 | 47 | (add-check! '(duplicate-module-name-pass "module m1 interface [v : int] body [v = 4] 48 | module m2 49 | interface [v : int] 50 | body [v = 3] 51 | from m1 take v" int)) 52 | 53 | 54 | (add-check! '(duplicate-module-name-error "module m1 interface [v : int] body [v = 4] 55 | module m2 56 | interface [v : int] 57 | body [v = 3] 58 | module m1 59 | interface [v : int] 60 | body [v = 4] 61 | from m1 take v" error)) 62 | 63 | (run "module m1 interface [v : int] body [v = 4] 64 | module m1 65 | interface [v : int] 66 | body [v = 10] 67 | from m1 take v") 68 | 69 | (check-all) 70 | -------------------------------------------------------------------------------- /base/chapter4/call-by-need/pairval2.scm: -------------------------------------------------------------------------------- 1 | (module pairval2 (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") 5 | 6 | (provide (all-defined)) 7 | 8 | ;;;;;;;;;;;;;;;; mutable pairs ;;;;;;;;;;;;;;;; 9 | 10 | ;; model a mutable pair as two consecutive locations (left and 11 | ;; right), and represent it as a reference to the first. 12 | 13 | ;; mutpair? : SchemeVal -> Bool 14 | ;; Page: 129 15 | ;; 16 | ;; Not every reference is really a mutpair, but this test is good 17 | ;; enough, because in the implicit-refs language, you 18 | ;; can't get your hands on a reference otherwise. 19 | (define mutpair? 20 | (lambda (v) 21 | (reference? v))) 22 | 23 | ;; make-pair : ExpVal * ExpVal -> MutPair 24 | ;; Page: 129 25 | (define make-pair 26 | (lambda (val1 val2) 27 | (let ((ref1 (newref val1))) 28 | (let ((ref2 (newref val2))) 29 | ref1)))) 30 | 31 | ;; left : MutPair -> ExpVal 32 | ;; Page: 129 33 | (define left 34 | (lambda (p) 35 | (deref p))) 36 | 37 | ;; right : MutPair -> ExpVal 38 | ;; Page: 129 39 | (define right 40 | (lambda (p) 41 | (deref (+ 1 p)))) 42 | 43 | ;; setleft : MutPair * ExpVal -> Unspecified 44 | ;; Page: 129 45 | (define setleft 46 | (lambda (p val) 47 | (setref! p val))) 48 | 49 | ;; setright : MutPair * Expval -> Unspecified 50 | ;; Page: 129 51 | (define setright 52 | (lambda (p val) 53 | (setref! (+ 1 p) val))) 54 | 55 | ) 56 | 57 | 58 | 59 | ;; (define mutpair? reference?) ; inaccurate 60 | 61 | ;; (define make-pair 62 | ;; (lambda (val1 val2) 63 | ;; (let ((ref1 (newref val1))) 64 | ;; (let ((ref2 (newref val2))) ; guaranteed to be ref1 + 1 65 | ;; ref1)))) 66 | 67 | ;; (define left 68 | ;; (lambda (p) 69 | ;; (deref p))) 70 | 71 | ;; (define right 72 | ;; (lambda (p) 73 | ;; (deref (+ 1 p)))) 74 | 75 | ;; (define setleft 76 | ;; (lambda (p val) 77 | ;; (setref! p val))) 78 | 79 | ;; (define setright 80 | ;; (lambda (p val) 81 | ;; (setref! (+ 1 p) val))) 82 | --------------------------------------------------------------------------------