├── .gitattributes ├── .gitignore ├── LICENSE.md ├── README.md ├── chapter1 └── test-chap1.scm ├── chapter2 ├── README.txt ├── sec2.1.scm ├── sec2.2-ds-rep.scm ├── sec2.2-proc-rep.scm ├── sec2.3.scm ├── sec2.4.scm ├── sec2.5.scm └── utils.scm ├── chapter3 ├── let-lang │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ └── top.scm ├── letrec-lang │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ └── top.scm ├── lexaddr-lang │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ ├── top.scm │ └── translator.scm └── proc-lang │ ├── ds-rep │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ └── top.scm │ └── proc-rep │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ └── top.scm ├── chapter4 ├── call-by-need │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── pairval1.scm │ ├── pairval2.scm │ ├── pairvals.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── call-by-reference │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── pairval1.scm │ ├── pairval2.scm │ ├── pairvals.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── explicit-refs │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── implicit-refs │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm └── mutable-pairs │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── pairval1.scm │ ├── pairval2.scm │ ├── pairvals.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── chapter5 ├── exceptions │ ├── big-trace3.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ └── top.scm ├── letrec-lang │ ├── data-structures.scm │ ├── drscheme-init-cps.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── eopl-without-exp.scm │ ├── interp-registers.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ ├── top-interp-registers.scm │ ├── top-interp.scm │ └── top.scm ├── test-all.scm └── thread-lang │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── interp.scm │ ├── lang.scm │ ├── queues.scm │ ├── scheduler.scm │ ├── semaphores.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── chapter6 ├── cps-lang │ ├── cps-in-lang.scm │ ├── cps-out-lang.scm │ ├── cps.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── interp.scm │ ├── tests.scm │ └── top.scm └── cps-side-effects-lang │ ├── cps-in-lang.scm │ ├── cps-out-lang.scm │ ├── cps.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── interp-tests.scm │ ├── interp.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── chapter7 ├── checked │ ├── checker.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── tests.scm │ └── top.scm └── inferred │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── equal-up-to-gensyms.scm │ ├── inferrer.scm │ ├── interp.scm │ ├── lang.scm │ ├── substitutions.scm │ ├── tests.scm │ ├── top.scm │ └── unifier.scm ├── chapter8 ├── abstract-types-lang │ ├── check-modules.scm │ ├── checker.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── expand-type.scm │ ├── interp.scm │ ├── lang.scm │ ├── renaming.scm │ ├── static-data-structures.scm │ ├── subtyping.scm │ ├── test-suite.scm │ ├── tests-book.scm │ └── top.scm ├── full-system │ ├── check-modules.scm │ ├── checker.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── expand-type.scm │ ├── interp.scm │ ├── lang.scm │ ├── renaming.scm │ ├── scratch.scm │ ├── static-data-structures.scm │ ├── subtyping.scm │ ├── test-suite.scm │ ├── tests-book.scm │ └── top.scm └── simplemodules │ ├── check-modules.scm │ ├── checker.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── expand-type.scm │ ├── interp.scm │ ├── lang.scm │ ├── static-data-structures.scm │ ├── subtyping.scm │ ├── test-suite.scm │ ├── tests-book.scm │ └── top.scm ├── chapter9 ├── classes │ ├── classes.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm └── typed-oo │ ├── checker.scm │ ├── classes.scm │ ├── data-structures.scm │ ├── drscheme-init.scm │ ├── environments.scm │ ├── interp.scm │ ├── lang.scm │ ├── static-classes.scm │ ├── static-data-structures.scm │ ├── store.scm │ ├── tests.scm │ └── top.scm ├── errata.html ├── errata.txt └── test-all.rkt /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | *.sln merge=union 7 | *.csproj merge=union 8 | *.vbproj merge=union 9 | *.fsproj merge=union 10 | *.dbproj merge=union 11 | 12 | # Standard to msysgit 13 | *.doc diff=astextplain 14 | *.DOC diff=astextplain 15 | *.docx diff=astextplain 16 | *.DOCX diff=astextplain 17 | *.dot diff=astextplain 18 | *.DOT diff=astextplain 19 | *.pdf diff=astextplain 20 | *.PDF diff=astextplain 21 | *.rtf diff=astextplain 22 | *.RTF diff=astextplain 23 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | This work is licensed under a [Creative Commons Attribution-Noncommercial 3.0 Unported License](http://creativecommons.org/licenses/by-nc/3.0/) . 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This is all the code from the book Essentials of Programming 2 | Languages, 3rd edition, by Friedman and Wand. 3 | 4 | The code dates from 2009. It has now been updated and should run 5 | right out of the box on Racket version 6.11. 6 | 7 | To run any of the languages, select "Choose language from source", and run top.scm in any of the language directories (chapterN/*-lang). 8 | 9 | The file test-all.rkt will go through and test all of the testable 10 | languages. 11 | 12 | If you are feeling adventurous, you can try to adapt the code 13 | base to use the rackunit testing framework instead of the kludgy one I 14 | threw together for the book. 15 | 16 | Enjoy! 17 | 18 | --Mitch 19 | 20 | 21 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /chapter2/sec2.1.scm: -------------------------------------------------------------------------------- 1 | (module sec2.1 (lib "eopl.ss" "eopl") 2 | 3 | (require "utils.scm") 4 | 5 | (let () 6 | ;; Unary Representation 7 | ;; page 33 8 | (define zero (lambda () '())) 9 | (define is-zero? (lambda (n) (null? n))) 10 | (define successor (lambda (n) (cons #t n))) 11 | (define predecessor (lambda (n) (cdr n))) 12 | 13 | ;; Need this style of definition to define a recursive function 14 | ;; inside a let, sorry. 15 | (define (plus x y) 16 | (if (is-zero? x) 17 | y 18 | (successor (plus (predecessor x) y)))) 19 | 20 | (define (scheme-int->my-int n) 21 | (if (zero? n) (zero) 22 | (successor (scheme-int->my-int (- n 1))))) 23 | 24 | (define (my-int->scheme-int x) 25 | (if (is-zero? x) 0 26 | (+ 1 (my-int->scheme-int (predecessor x))))) 27 | 28 | (equal?? 29 | (my-int->scheme-int 30 | (plus 31 | (scheme-int->my-int 3) 32 | (scheme-int->my-int 7))) 33 | 10) 34 | 35 | (report-unit-tests-completed 'unary-representation) 36 | ) 37 | 38 | (let () 39 | ;; Scheme number representation 40 | ;; page 33 41 | (define zero (lambda () 0)) 42 | (define is-zero? (lambda (n) (zero? n))) 43 | (define successor (lambda (n) (+ n 1))) 44 | (define predecessor (lambda (n) (- n 1))) 45 | 46 | (define (plus x y) 47 | (if (is-zero? x) 48 | y 49 | (successor (plus (predecessor x) y)))) 50 | 51 | (equal?? (plus 3 7) 10) 52 | 53 | (report-unit-tests-completed 'scheme-number-representation) 54 | 55 | ) 56 | 57 | (let () 58 | ;; Reverse-number representation 59 | ;; Represent n by the Scheme number 5-n 60 | (define zero (lambda () 5)) 61 | (define is-zero? (lambda (n) (= n 5))) 62 | (define successor (lambda (n) (- n 5))) 63 | (define predecessor (lambda (n) (+ n 5))) 64 | 65 | ;; unchanged below here! 66 | 67 | (define plus 68 | (lambda (x y) 69 | (if (is-zero? x) 70 | y 71 | (successor (plus (predecessor x) y))))) 72 | 73 | (define (scheme-int->my-int n) 74 | (if (zero? n) (zero) 75 | (successor (scheme-int->my-int (- n 1))))) 76 | 77 | (define (my-int->scheme-int x) 78 | (if (is-zero? x) 0 79 | (+ 1 (my-int->scheme-int (predecessor x))))) 80 | 81 | (equal?? 82 | (my-int->scheme-int 83 | (plus 84 | (scheme-int->my-int 3) 85 | (scheme-int->my-int 7))) 86 | 10) 87 | 88 | (report-unit-tests-completed 'reverse-number-representation) 89 | ) 90 | 91 | ) 92 | 93 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /chapter2/sec2.3.scm: -------------------------------------------------------------------------------- 1 | (module sec2.3 (lib "eopl.ss" "eopl") 2 | 3 | (require "utils.scm") 4 | 5 | ;; var-exp : Var -> Lc-exp 6 | (define var-exp 7 | (lambda (var) 8 | `(var-exp ,var))) 9 | 10 | ;; lambda-exp : Var * Lc-exp -> Lc-exp 11 | (define lambda-exp 12 | (lambda (var lc-exp) 13 | `(lambda-exp ,var ,lc-exp))) 14 | 15 | ;; app-exp : Lc-exp * Lc-exp -> Lc-exp 16 | (define app-exp 17 | (lambda (lc-exp1 lc-exp2) 18 | `(app-exp ,lc-exp1 ,lc-exp2))) 19 | 20 | ;; var-exp? : Lc-exp -> Bool 21 | (define var-exp? 22 | (lambda (x) 23 | (and (pair? x) (eq? (car x) 'var-exp)))) 24 | 25 | ;; lambda-exp? : Lc-exp -> Bool 26 | (define lambda-exp? 27 | (lambda (x) 28 | (and (pair? x) (eq? (car x) 'lambda-exp)))) 29 | 30 | ;; app-exp? : Lc-exp -> Bool 31 | (define app-exp? 32 | (lambda (x) 33 | (and (pair? x) (eq? (car x) 'app-exp)))) 34 | ;; var-exp->var : Lc-exp -> Var 35 | (define var-exp->var 36 | (lambda (x) 37 | (cadr x))) 38 | 39 | ;; lambda-exp->bound-var : Lc-exp -> Var 40 | (define lambda-exp->bound-var 41 | (lambda (x) 42 | (cadr x))) 43 | 44 | ;; lambda-exp->body : Lc-exp -> Lc-exp 45 | (define lambda-exp->body 46 | (lambda (x) 47 | (caddr x))) 48 | 49 | ;; app-exp->rator : Lc-exp -> Lc-exp 50 | (define app-exp->rator 51 | (lambda (x) 52 | (cadr x))) 53 | 54 | ;; app-exp->rand : Lc-exp -> Lc-exp 55 | (define app-exp->rand 56 | (lambda (x) 57 | (caddr x))) 58 | 59 | ;; occurs-free? : Sym * Lcexp -> Bool 60 | (define occurs-free? 61 | (lambda (search-var exp) 62 | (cond 63 | ((var-exp? exp) (eqv? search-var (var-exp->var exp))) 64 | ((lambda-exp? exp) 65 | (and 66 | (not (eqv? search-var (lambda-exp->bound-var exp))) 67 | (occurs-free? search-var (lambda-exp->body exp)))) 68 | (else 69 | (or 70 | (occurs-free? search-var (app-exp->rator exp)) 71 | (occurs-free? search-var (app-exp->rand exp))))))) 72 | 73 | ;; a few small unit tests 74 | 75 | (equal?? 76 | (occurs-free? 'a (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a)))) 77 | #f) 78 | 79 | (equal?? 80 | (occurs-free? 'b (lambda-exp 'a (app-exp (var-exp 'b) (var-exp 'a)))) 81 | #t) 82 | 83 | (report-unit-tests-completed 'occurs-free?) 84 | 85 | ) -------------------------------------------------------------------------------- /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 | #t))))) 16 | 17 | (define report-unit-tests-completed 18 | (lambda (fn-name) 19 | (eopl:printf "unit tests completed: ~s~%" fn-name))) 20 | 21 | ) 22 | -------------------------------------------------------------------------------- /chapter3/let-lang/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | ;; data structures for let-lang. 4 | 5 | (provide (all-defined-out)) ; 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 | 17 | ;;; extractors: 18 | 19 | ;; expval->num : ExpVal -> Int 20 | ;; Page: 70 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 | ;; expval->bool : ExpVal -> Bool 28 | ;; Page: 70 29 | (define expval->bool 30 | (lambda (v) 31 | (cases expval v 32 | (bool-val (bool) bool) 33 | (else (expval-extractor-error 'bool v))))) 34 | 35 | (define expval-extractor-error 36 | (lambda (variant value) 37 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 38 | variant value))) 39 | 40 | ;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;; 41 | 42 | ;; example of a data type built without define-datatype 43 | 44 | (define empty-env-record 45 | (lambda () 46 | '())) 47 | 48 | (define extended-env-record 49 | (lambda (sym val old-env) 50 | (cons (list sym val) old-env))) 51 | 52 | (define empty-env-record? null?) 53 | 54 | (define environment? 55 | (lambda (x) 56 | (or (empty-env-record? x) 57 | (and (pair? x) 58 | (symbol? (car (car x))) 59 | (expval? (cadr (car x))) 60 | (environment? (cdr x)))))) 61 | 62 | (define extended-env-record->sym 63 | (lambda (r) 64 | (car (car r)))) 65 | 66 | (define extended-env-record->val 67 | (lambda (r) 68 | (cadr (car r)))) 69 | 70 | (define extended-env-record->old-env 71 | (lambda (r) 72 | (cdr r))) 73 | 74 | ) 75 | -------------------------------------------------------------------------------- /chapter3/let-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 | (define empty-env 32 | (lambda () 33 | (empty-env-record))) 34 | 35 | (define empty-env? 36 | (lambda (x) 37 | (empty-env-record? x))) 38 | 39 | (define extend-env 40 | (lambda (sym val old-env) 41 | (extended-env-record sym val old-env))) 42 | 43 | (define apply-env 44 | (lambda (env search-sym) 45 | (if (empty-env? env) 46 | (eopl:error 'apply-env "No binding for ~s" search-sym) 47 | (let ((sym (extended-env-record->sym env)) 48 | (val (extended-env-record->val env)) 49 | (old-env (extended-env-record->old-env env))) 50 | (if (eqv? search-sym sym) 51 | val 52 | (apply-env old-env search-sym)))))) 53 | 54 | ) -------------------------------------------------------------------------------- /chapter3/let-lang/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | ;; interpreter for the LET language. The \commentboxes are the 4 | ;; latex code for inserting the rules into the code in the book. 5 | ;; These are too complicated to put here, see the text, sorry. 6 | 7 | (require "drscheme-init.scm") 8 | 9 | (require "lang.scm") 10 | (require "data-structures.scm") 11 | (require "environments.scm") 12 | 13 | (provide value-of-program value-of) 14 | 15 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 16 | 17 | ;; value-of-program : Program -> ExpVal 18 | ;; Page: 71 19 | (define value-of-program 20 | (lambda (pgm) 21 | (cases program pgm 22 | (a-program (exp1) 23 | (value-of exp1 (init-env)))))) 24 | 25 | ;; value-of : Exp * Env -> ExpVal 26 | ;; Page: 71 27 | (define value-of 28 | (lambda (exp env) 29 | (cases expression exp 30 | 31 | ;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}} 32 | (const-exp (num) (num-val num)) 33 | 34 | ;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})} 35 | (var-exp (var) (apply-env env var)) 36 | 37 | ;\commentbox{\diffspec} 38 | (diff-exp (exp1 exp2) 39 | (let ((val1 (value-of exp1 env)) 40 | (val2 (value-of exp2 env))) 41 | (let ((num1 (expval->num val1)) 42 | (num2 (expval->num val2))) 43 | (num-val 44 | (- num1 num2))))) 45 | 46 | ;\commentbox{\zerotestspec} 47 | (zero?-exp (exp1) 48 | (let ((val1 (value-of exp1 env))) 49 | (let ((num1 (expval->num val1))) 50 | (if (zero? num1) 51 | (bool-val #t) 52 | (bool-val #f))))) 53 | 54 | ;\commentbox{\ma{\theifspec}} 55 | (if-exp (exp1 exp2 exp3) 56 | (let ((val1 (value-of exp1 env))) 57 | (if (expval->bool val1) 58 | (value-of exp2 env) 59 | (value-of exp3 env)))) 60 | 61 | ;\commentbox{\ma{\theletspecsplit}} 62 | (let-exp (var exp1 body) 63 | (let ((val1 (value-of exp1 env))) 64 | (value-of body 65 | (extend-env var val1 env)))) 66 | 67 | ))) 68 | 69 | 70 | ) 71 | 72 | -------------------------------------------------------------------------------- /chapter3/let-lang/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang 2 | 3 | ;; grammar for the LET language 4 | 5 | (lib "eopl.ss" "eopl") 6 | 7 | (require "drscheme-init.scm") 8 | 9 | (provide (all-defined-out)) 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 | )) 46 | 47 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 48 | 49 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 50 | 51 | (define show-the-datatypes 52 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 53 | 54 | (define scan&parse 55 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 56 | 57 | (define just-scan 58 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 59 | 60 | ) 61 | -------------------------------------------------------------------------------- /chapter3/let-lang/tests.scm: -------------------------------------------------------------------------------- 1 | (module tests mzscheme 2 | 3 | (provide test-list) 4 | 5 | ;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;; 6 | 7 | (define test-list 8 | '( 9 | 10 | ;; simple arithmetic 11 | (positive-const "11" 11) 12 | (negative-const "-33" -33) 13 | (simple-arith-1 "-(44,33)" 11) 14 | 15 | ;; nested arithmetic 16 | (nested-arith-left "-(-(44,33),22)" -11) 17 | (nested-arith-right "-(55, -(22,11))" 44) 18 | 19 | ;; simple variables 20 | (test-var-1 "x" 10) 21 | (test-var-2 "-(x,1)" 9) 22 | (test-var-3 "-(1,x)" -9) 23 | 24 | ;; simple unbound variables 25 | (test-unbound-var-1 "foo" error) 26 | (test-unbound-var-2 "-(x,foo)" error) 27 | 28 | ;; simple conditionals 29 | (if-true "if zero?(0) then 3 else 4" 3) 30 | (if-false "if zero?(1) then 3 else 4" 4) 31 | 32 | ;; test dynamic typechecking 33 | (no-bool-to-diff-1 "-(zero?(0),1)" error) 34 | (no-bool-to-diff-2 "-(1,zero?(0))" error) 35 | (no-int-to-if "if 1 then 2 else 3" error) 36 | 37 | ;; make sure that the test and both arms get evaluated 38 | ;; properly. 39 | (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3) 40 | (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4) 41 | 42 | ;; and make sure the other arm doesn't get evaluated. 43 | (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3) 44 | (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4) 45 | 46 | ;; simple let 47 | (simple-let-1 "let x = 3 in x" 3) 48 | 49 | ;; make sure the body and rhs get evaluated 50 | (eval-let-body "let x = 3 in -(x,1)" 2) 51 | (eval-let-rhs "let x = -(4,1) in -(x,1)" 2) 52 | 53 | ;; check nested let and shadowing 54 | (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1) 55 | (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4) 56 | (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2) 57 | 58 | )) 59 | ) -------------------------------------------------------------------------------- /chapter3/let-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 | (provide test-all) 18 | 19 | (define (test-all) (run-all)) 20 | 21 | ;; here are some other things that could be provided: 22 | 23 | ;; (provide (all-defined-out)) 24 | ;; (provide (all-from "interp.scm")) 25 | ;; (provide (all-from "lang.scm")) 26 | 27 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 28 | 29 | ;; run : String -> ExpVal 30 | ;; Page: 71 31 | (define run 32 | (lambda (string) 33 | (value-of-program (scan&parse string)))) 34 | 35 | ;; run-all : () -> unspecified 36 | 37 | ;; runs all the tests in test-list, comparing the results with 38 | ;; equal-answer? 39 | 40 | (define run-all 41 | (lambda () 42 | (run-tests! run equal-answer? test-list))) 43 | 44 | (define equal-answer? 45 | (lambda (ans correct-ans) 46 | (equal? ans (sloppy->expval correct-ans)))) 47 | 48 | (define sloppy->expval 49 | (lambda (sloppy-val) 50 | (cond 51 | ((number? sloppy-val) (num-val sloppy-val)) 52 | ((boolean? sloppy-val) (bool-val sloppy-val)) 53 | (else 54 | (eopl:error 'sloppy->expval 55 | "Can't convert sloppy value to expval: ~s" 56 | sloppy-val))))) 57 | 58 | ;; run-one : symbol -> expval 59 | 60 | ;; (run-one sym) runs the test whose name is sym 61 | 62 | (define run-one 63 | (lambda (test-name) 64 | (let ((the-test (assoc test-name test-list))) 65 | (cond 66 | ((assoc test-name test-list) 67 | => (lambda (test) 68 | (run (cadr test)))) 69 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 70 | 71 | ;; (run-all) 72 | 73 | ) 74 | 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /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-out)) ; 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 | ) 73 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter3/letrec-lang/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | ;; interpreter for the LETREC language. The \commentboxes are the 4 | ;; latex code for inserting the rules into the code in the book. 5 | ;; These are too complicated to put here, see the text, sorry. 6 | 7 | (require "drscheme-init.scm") 8 | 9 | (require "lang.scm") 10 | (require "data-structures.scm") 11 | (require "environments.scm") 12 | 13 | (provide value-of-program value-of) 14 | 15 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 16 | 17 | ;; value-of-program : Program -> ExpVal 18 | (define value-of-program 19 | (lambda (pgm) 20 | (cases program pgm 21 | (a-program (exp1) 22 | (value-of exp1 (init-env)))))) 23 | 24 | ;; value-of : Exp * Env -> ExpVal 25 | ;; Page: 83 26 | (define value-of 27 | (lambda (exp env) 28 | (cases expression exp 29 | 30 | ;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}} 31 | (const-exp (num) (num-val num)) 32 | 33 | ;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})} 34 | (var-exp (var) (apply-env env var)) 35 | 36 | ;\commentbox{\diffspec} 37 | (diff-exp (exp1 exp2) 38 | (let ((val1 (value-of exp1 env)) 39 | (val2 (value-of exp2 env))) 40 | (let ((num1 (expval->num val1)) 41 | (num2 (expval->num val2))) 42 | (num-val 43 | (- num1 num2))))) 44 | 45 | ;\commentbox{\zerotestspec} 46 | (zero?-exp (exp1) 47 | (let ((val1 (value-of exp1 env))) 48 | (let ((num1 (expval->num val1))) 49 | (if (zero? num1) 50 | (bool-val #t) 51 | (bool-val #f))))) 52 | 53 | ;\commentbox{\ma{\theifspec}} 54 | (if-exp (exp1 exp2 exp3) 55 | (let ((val1 (value-of exp1 env))) 56 | (if (expval->bool val1) 57 | (value-of exp2 env) 58 | (value-of exp3 env)))) 59 | 60 | ;\commentbox{\ma{\theletspecsplit}} 61 | (let-exp (var exp1 body) 62 | (let ((val1 (value-of exp1 env))) 63 | (value-of body 64 | (extend-env var val1 env)))) 65 | 66 | (proc-exp (var body) 67 | (proc-val (procedure var body env))) 68 | 69 | (call-exp (rator rand) 70 | (let ((proc (expval->proc (value-of rator env))) 71 | (arg (value-of rand env))) 72 | (apply-procedure proc arg))) 73 | 74 | (letrec-exp (p-name b-var p-body letrec-body) 75 | (value-of letrec-body 76 | (extend-env-rec p-name b-var p-body env))) 77 | 78 | ))) 79 | 80 | ;; apply-procedure : Proc * ExpVal -> ExpVal 81 | 82 | (define apply-procedure 83 | (lambda (proc1 arg) 84 | (cases proc proc1 85 | (procedure (var body saved-env) 86 | (value-of body (extend-env var arg saved-env)))))) 87 | 88 | ) 89 | 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /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 for book test ;;; 18 | (provide test-all) 19 | (define (test-all) (run-all)) 20 | 21 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 22 | 23 | ;; run : String -> ExpVal 24 | (define run 25 | (lambda (string) 26 | (value-of-program (scan&parse string)))) 27 | 28 | ;; run-all : () -> Unspecified 29 | 30 | ;; runs all the tests in test-list, comparing the results with 31 | ;; equal-answer? 32 | 33 | (define run-all 34 | (lambda () 35 | (run-tests! run equal-answer? test-list))) 36 | 37 | (define equal-answer? 38 | (lambda (ans correct-ans) 39 | (equal? ans (sloppy->expval correct-ans)))) 40 | 41 | (define sloppy->expval 42 | (lambda (sloppy-val) 43 | (cond 44 | ((number? sloppy-val) (num-val sloppy-val)) 45 | ((boolean? sloppy-val) (bool-val sloppy-val)) 46 | (else 47 | (eopl:error 'sloppy->expval 48 | "Can't convert sloppy value to expval: ~s" 49 | sloppy-val))))) 50 | 51 | ;; run-one : Sym -> ExpVal 52 | 53 | ;; (run-one sym) runs the test whose name is sym 54 | 55 | (define run-one 56 | (lambda (test-name) 57 | (let ((the-test (assoc test-name test-list))) 58 | (cond 59 | ((assoc test-name test-list) 60 | => (lambda (test) 61 | (run (cadr test)))) 62 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 63 | 64 | ;; (run-all) 65 | 66 | ) 67 | 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /chapter3/lexaddr-lang/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | ;; data structures for LEXADDR language 4 | 5 | (require "lang.scm") ; for expression? 6 | 7 | (provide (all-defined-out)) ; 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 | 52 | ;; proc? : SchemeVal -> Bool 53 | ;; procedure : Exp * Nameless-env -> Proc 54 | (define-datatype proc proc? 55 | (procedure 56 | ;; in LEXADDR, bound variables are replaced by %nameless-vars, so 57 | ;; there is no need to declare bound variables. 58 | ;; (bvar symbol?) 59 | (body expression?) 60 | ;; and the closure contains a nameless environment 61 | (env nameless-environment?))) 62 | 63 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 64 | 65 | ;; nameless-environment? : SchemeVal -> Bool 66 | ;; Page: 99 67 | (define nameless-environment? 68 | (lambda (x) 69 | ((list-of expval?) x))) 70 | 71 | ;; empty-nameless-env : () -> Nameless-env 72 | ;; Page: 99 73 | (define empty-nameless-env 74 | (lambda () 75 | '())) 76 | 77 | ;; empty-nameless-env? : Nameless-env -> Bool 78 | (define empty-nameless-env? 79 | (lambda (x) 80 | (null? x))) 81 | 82 | ;; extend-nameless-env : ExpVal * Nameless-env -> Nameless-env 83 | ;; Page: 99 84 | (define extend-nameless-env 85 | (lambda (val nameless-env) 86 | (cons val nameless-env))) 87 | 88 | ;; apply-nameless-env : Nameless-env * Lexaddr -> ExpVal 89 | ;; Page: 99 90 | (define apply-nameless-env 91 | (lambda (nameless-env n) 92 | (list-ref nameless-env n))) 93 | 94 | ) 95 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter3/lexaddr-lang/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | ;; interpreter for the LEXADDR language. 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (require "lang.scm") 8 | (require "data-structures.scm") 9 | (require "environments.scm") 10 | 11 | (provide value-of-translation value-of) 12 | 13 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 14 | 15 | ;; value-of-translation : Nameless-program -> ExpVal 16 | 17 | (define value-of-translation 18 | (lambda (pgm) 19 | (cases program pgm 20 | (a-program (exp1) 21 | (value-of exp1 (init-nameless-env)))))) 22 | 23 | ;; value-of-translation : Nameless-program -> ExpVal 24 | ;; Page: 100 25 | (define value-of-program 26 | (lambda (pgm) 27 | (cases program pgm 28 | (a-program (exp1) 29 | (value-of exp1 (init-nameless-env)))))) 30 | 31 | ;; value-of : Nameless-exp * Nameless-env -> ExpVal 32 | (define value-of 33 | (lambda (exp nameless-env) 34 | (cases expression exp 35 | (const-exp (num) (num-val num)) 36 | 37 | (diff-exp (exp1 exp2) 38 | (let ((val1 39 | (expval->num 40 | (value-of exp1 nameless-env))) 41 | (val2 42 | (expval->num 43 | (value-of exp2 nameless-env)))) 44 | (num-val 45 | (- val1 val2)))) 46 | 47 | (zero?-exp (exp1) 48 | (let ((val1 (expval->num (value-of exp1 nameless-env)))) 49 | (if (zero? val1) 50 | (bool-val #t) 51 | (bool-val #f)))) 52 | 53 | (if-exp (exp0 exp1 exp2) 54 | (if (expval->bool (value-of exp0 nameless-env)) 55 | (value-of exp1 nameless-env) 56 | (value-of exp2 nameless-env))) 57 | 58 | (call-exp (rator rand) 59 | (let ((proc (expval->proc (value-of rator nameless-env))) 60 | (arg (value-of rand nameless-env))) 61 | (apply-procedure proc arg))) 62 | 63 | (nameless-var-exp (n) 64 | (apply-nameless-env nameless-env n)) 65 | 66 | (nameless-let-exp (exp1 body) 67 | (let ((val (value-of exp1 nameless-env))) 68 | (value-of body 69 | (extend-nameless-env val nameless-env)))) 70 | 71 | (nameless-proc-exp (body) 72 | (proc-val 73 | (procedure body nameless-env))) 74 | 75 | (else 76 | (eopl:error 'value-of 77 | "Illegal expression in translated code: ~s" exp)) 78 | 79 | ))) 80 | 81 | 82 | ;; apply-procedure : Proc * ExpVal -> ExpVal 83 | 84 | (define apply-procedure 85 | (lambda (proc1 arg) 86 | (cases proc proc1 87 | (procedure (body saved-env) 88 | (value-of body (extend-nameless-env arg saved-env)))))) 89 | 90 | ) 91 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /chapter3/lexaddr-lang/tests.scm: -------------------------------------------------------------------------------- 1 | (module tests mzscheme 2 | 3 | (provide test-list) 4 | ;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;; 5 | 6 | (define test-list 7 | '( 8 | 9 | ;; simple arithmetic 10 | (positive-const "11" 11) 11 | (negative-const "-33" -33) 12 | (simple-arith-1 "-(44,33)" 11) 13 | 14 | ;; nested arithmetic 15 | (nested-arith-left "-(-(44,33),22)" -11) 16 | (nested-arith-right "-(55, -(22,11))" 44) 17 | 18 | ;; simple variables 19 | (test-var-1 "x" 10) 20 | (test-var-2 "-(x,1)" 9) 21 | (test-var-3 "-(1,x)" -9) 22 | 23 | ;; simple unbound variables 24 | (test-unbound-var-1 "foo" error) 25 | (test-unbound-var-2 "-(x,foo)" error) 26 | 27 | ;; simple conditionals 28 | (if-true "if zero?(0) then 3 else 4" 3) 29 | (if-false "if zero?(1) then 3 else 4" 4) 30 | 31 | ;; test dynamic typechecking 32 | (no-bool-to-diff-1 "-(zero?(0),1)" error) 33 | (no-bool-to-diff-2 "-(1,zero?(0))" error) 34 | (no-int-to-if "if 1 then 2 else 3" error) 35 | 36 | ;; make sure that the test and both arms get evaluated 37 | ;; properly. 38 | (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3) 39 | (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4) 40 | 41 | ; these aren't translatable. Exercise: make them translatable by 42 | ; providing a binding for foo. 43 | ; ;; and make sure the other arm doesn't get evaluated. 44 | ; (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3) 45 | ; (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4) 46 | 47 | ;; simple let 48 | (simple-let-1 "let x = 3 in x" 3) 49 | 50 | ;; make sure the body and rhs get evaluated 51 | (eval-let-body "let x = 3 in -(x,1)" 2) 52 | (eval-let-rhs "let x = -(4,1) in -(x,1)" 2) 53 | 54 | ;; check nested let and shadowing 55 | (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1) 56 | (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4) 57 | (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2) 58 | 59 | ;; simple applications 60 | (apply-proc-in-rator-pos "(proc(x) -(x,1) 30)" 29) 61 | (apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29) 62 | (let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29) 63 | 64 | 65 | (nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1) 66 | (nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)" 67 | -1) 68 | 69 | (y-combinator-1 " 70 | let fix = proc (f) 71 | let d = proc (x) proc (z) ((f (x x)) z) 72 | in proc (n) ((f (d d)) n) 73 | in let 74 | t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4) 75 | in let times4 = (fix t4m) 76 | in (times4 3)" 12) 77 | )) 78 | ) -------------------------------------------------------------------------------- /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 | ;;;; function for automated testing ;;;; 16 | (provide test-all) 17 | (define (test-all) (run-all)) 18 | 19 | 20 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 21 | 22 | ;; run : String -> ExpVal 23 | ;; Page: 98 24 | (define run 25 | (lambda (string) 26 | (value-of-translation 27 | (translation-of-program 28 | (scan&parse string))))) 29 | 30 | ;; run-all : () -> Unspecified 31 | 32 | ;; runs all the tests in test-list, comparing the results with 33 | ;; equal-answer? 34 | 35 | (define run-all 36 | (lambda () 37 | (run-tests! run equal-answer? test-list))) 38 | 39 | (define equal-answer? 40 | (lambda (ans correct-ans) 41 | (equal? ans (sloppy->expval correct-ans)))) 42 | 43 | (define sloppy->expval 44 | (lambda (sloppy-val) 45 | (cond 46 | ((number? sloppy-val) (num-val sloppy-val)) 47 | ((boolean? sloppy-val) (bool-val sloppy-val)) 48 | (else 49 | (eopl:error 'sloppy->expval 50 | "Can't convert sloppy value to expval: ~s" 51 | sloppy-val))))) 52 | 53 | ;; run-one : Sym -> ExpVal 54 | 55 | ;; (run-one sym) runs the test whose name is sym 56 | 57 | (define run-one 58 | (lambda (test-name) 59 | (let ((the-test (assoc test-name test-list))) 60 | (cond 61 | ((assoc test-name test-list) 62 | => (lambda (test) 63 | (run (cadr test)))) 64 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 65 | 66 | ;; (run-all) 67 | 68 | ) 69 | 70 | 71 | 72 | 73 | -------------------------------------------------------------------------------- /chapter3/lexaddr-lang/translator.scm: -------------------------------------------------------------------------------- 1 | (module translator (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") 4 | 5 | (provide translation-of-program) 6 | ;;;;;;;;;;;;;;;; lexical address calculator ;;;;;;;;;;;;;;;; 7 | 8 | ;; translation-of-program : Program -> Nameless-program 9 | ;; Page: 96 10 | (define translation-of-program 11 | (lambda (pgm) 12 | (cases program pgm 13 | (a-program (exp1) 14 | (a-program 15 | (translation-of exp1 (init-senv))))))) 16 | 17 | ;; translation-of : Exp * Senv -> Nameless-exp 18 | ;; Page 97 19 | (define translation-of 20 | (lambda (exp senv) 21 | (cases expression exp 22 | (const-exp (num) (const-exp num)) 23 | (diff-exp (exp1 exp2) 24 | (diff-exp 25 | (translation-of exp1 senv) 26 | (translation-of exp2 senv))) 27 | (zero?-exp (exp1) 28 | (zero?-exp 29 | (translation-of exp1 senv))) 30 | (if-exp (exp1 exp2 exp3) 31 | (if-exp 32 | (translation-of exp1 senv) 33 | (translation-of exp2 senv) 34 | (translation-of exp3 senv))) 35 | (var-exp (var) 36 | (nameless-var-exp 37 | (apply-senv senv var))) 38 | (let-exp (var exp1 body) 39 | (nameless-let-exp 40 | (translation-of exp1 senv) 41 | (translation-of body 42 | (extend-senv var senv)))) 43 | (proc-exp (var body) 44 | (nameless-proc-exp 45 | (translation-of body 46 | (extend-senv var senv)))) 47 | (call-exp (rator rand) 48 | (call-exp 49 | (translation-of rator senv) 50 | (translation-of rand senv))) 51 | (else (report-invalid-source-expression exp)) 52 | ))) 53 | 54 | (define report-invalid-source-expression 55 | (lambda (exp) 56 | (eopl:error 'value-of 57 | "Illegal expression in source code: ~s" exp))) 58 | 59 | ;;;;;;;;;;;;;;;; static environments ;;;;;;;;;;;;;;;; 60 | 61 | ;;; Senv = Listof(Sym) 62 | ;;; Lexaddr = N 63 | 64 | ;; empty-senv : () -> Senv 65 | ;; Page: 95 66 | (define empty-senv 67 | (lambda () 68 | '())) 69 | 70 | ;; extend-senv : Var * Senv -> Senv 71 | ;; Page: 95 72 | (define extend-senv 73 | (lambda (var senv) 74 | (cons var senv))) 75 | 76 | ;; apply-senv : Senv * Var -> Lexaddr 77 | ;; Page: 95 78 | (define apply-senv 79 | (lambda (senv var) 80 | (cond 81 | ((null? senv) (report-unbound-var var)) 82 | ((eqv? var (car senv)) 83 | 0) 84 | (else 85 | (+ 1 (apply-senv (cdr senv) var)))))) 86 | 87 | (define report-unbound-var 88 | (lambda (var) 89 | (eopl:error 'translation-of "unbound variable in code: ~s" var))) 90 | 91 | ;; init-senv : () -> Senv 92 | ;; Page: 96 93 | (define init-senv 94 | (lambda () 95 | (extend-senv 'i 96 | (extend-senv 'v 97 | (extend-senv 'x 98 | (empty-senv)))))) 99 | 100 | ) 101 | -------------------------------------------------------------------------------- /chapter3/proc-lang/ds-rep/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | ;; data structures for proc-lang/ds-rep 4 | 5 | (require "lang.scm") ; for expression? 6 | 7 | (provide (all-defined-out)) ; 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 | (var symbol?) 56 | (body expression?) 57 | (env environment?))) 58 | 59 | ;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;; 60 | 61 | ;; example of a data type built without define-datatype 62 | 63 | (define empty-env-record 64 | (lambda () 65 | '())) 66 | 67 | (define extended-env-record 68 | (lambda (sym val old-env) 69 | (cons (list sym val) old-env))) 70 | 71 | (define empty-env-record? null?) 72 | 73 | (define environment? 74 | (lambda (x) 75 | (or (empty-env-record? x) 76 | (and (pair? x) 77 | (symbol? (car (car x))) 78 | (expval? (cadr (car x))) 79 | (environment? (cdr x)))))) 80 | 81 | (define extended-env-record->sym 82 | (lambda (r) 83 | (car (car r)))) 84 | 85 | (define extended-env-record->val 86 | (lambda (r) 87 | (cadr (car r)))) 88 | 89 | (define extended-env-record->old-env 90 | (lambda (r) 91 | (cdr r))) 92 | 93 | ) 94 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter3/proc-lang/ds-rep/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | ;; interpreter for the PROC language, using the data structure 4 | ;; representation of procedures. 5 | 6 | ;; The \commentboxes are the latex code for inserting the rules into 7 | ;; the code in the book. These are too complicated to put here, see 8 | ;; the text, sorry. 9 | 10 | (require "drscheme-init.scm") 11 | 12 | (require "lang.scm") 13 | (require "data-structures.scm") 14 | (require "environments.scm") 15 | 16 | (provide value-of-program value-of) 17 | 18 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 19 | 20 | ;; value-of-program : Program -> ExpVal 21 | (define value-of-program 22 | (lambda (pgm) 23 | (cases program pgm 24 | (a-program (exp1) 25 | (value-of exp1 (init-env)))))) 26 | 27 | ;; value-of : Exp * Env -> ExpVal 28 | (define value-of 29 | (lambda (exp env) 30 | (cases expression exp 31 | 32 | ;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}} 33 | (const-exp (num) (num-val num)) 34 | 35 | ;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})} 36 | (var-exp (var) (apply-env env var)) 37 | 38 | ;\commentbox{\diffspec} 39 | (diff-exp (exp1 exp2) 40 | (let ((val1 (value-of exp1 env)) 41 | (val2 (value-of exp2 env))) 42 | (let ((num1 (expval->num val1)) 43 | (num2 (expval->num val2))) 44 | (num-val 45 | (- num1 num2))))) 46 | 47 | ;\commentbox{\zerotestspec} 48 | (zero?-exp (exp1) 49 | (let ((val1 (value-of exp1 env))) 50 | (let ((num1 (expval->num val1))) 51 | (if (zero? num1) 52 | (bool-val #t) 53 | (bool-val #f))))) 54 | 55 | ;\commentbox{\ma{\theifspec}} 56 | (if-exp (exp1 exp2 exp3) 57 | (let ((val1 (value-of exp1 env))) 58 | (if (expval->bool val1) 59 | (value-of exp2 env) 60 | (value-of exp3 env)))) 61 | 62 | ;\commentbox{\ma{\theletspecsplit}} 63 | (let-exp (var exp1 body) 64 | (let ((val1 (value-of exp1 env))) 65 | (value-of body 66 | (extend-env var val1 env)))) 67 | 68 | (proc-exp (var body) 69 | (proc-val (procedure var body env))) 70 | 71 | (call-exp (rator rand) 72 | (let ((proc (expval->proc (value-of rator env))) 73 | (arg (value-of rand env))) 74 | (apply-procedure proc arg))) 75 | 76 | ))) 77 | 78 | ;; apply-procedure : Proc * ExpVal -> ExpVal 79 | ;; Page: 79 80 | (define apply-procedure 81 | (lambda (proc1 val) 82 | (cases proc proc1 83 | (procedure (var body saved-env) 84 | (value-of body (extend-env var val saved-env)))))) 85 | 86 | ) 87 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /chapter3/proc-lang/ds-rep/tests.scm: -------------------------------------------------------------------------------- 1 | (module tests mzscheme 2 | 3 | (provide test-list) 4 | 5 | ;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;; 6 | 7 | (define test-list 8 | '( 9 | 10 | ;; simple arithmetic 11 | (positive-const "11" 11) 12 | (negative-const "-33" -33) 13 | (simple-arith-1 "-(44,33)" 11) 14 | 15 | ;; nested arithmetic 16 | (nested-arith-left "-(-(44,33),22)" -11) 17 | (nested-arith-right "-(55, -(22,11))" 44) 18 | 19 | ;; simple variables 20 | (test-var-1 "x" 10) 21 | (test-var-2 "-(x,1)" 9) 22 | (test-var-3 "-(1,x)" -9) 23 | 24 | ;; simple unbound variables 25 | (test-unbound-var-1 "foo" error) 26 | (test-unbound-var-2 "-(x,foo)" error) 27 | 28 | ;; simple conditionals 29 | (if-true "if zero?(0) then 3 else 4" 3) 30 | (if-false "if zero?(1) then 3 else 4" 4) 31 | 32 | ;; test dynamic typechecking 33 | (no-bool-to-diff-1 "-(zero?(0),1)" error) 34 | (no-bool-to-diff-2 "-(1,zero?(0))" error) 35 | (no-int-to-if "if 1 then 2 else 3" error) 36 | 37 | ;; make sure that the test and both arms get evaluated 38 | ;; properly. 39 | (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3) 40 | (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4) 41 | 42 | ;; and make sure the other arm doesn't get evaluated. 43 | (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3) 44 | (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4) 45 | 46 | ;; simple let 47 | (simple-let-1 "let x = 3 in x" 3) 48 | 49 | ;; make sure the body and rhs get evaluated 50 | (eval-let-body "let x = 3 in -(x,1)" 2) 51 | (eval-let-rhs "let x = -(4,1) in -(x,1)" 2) 52 | 53 | ;; check nested let and shadowing 54 | (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1) 55 | (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4) 56 | (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2) 57 | 58 | ;; simple applications 59 | (apply-proc-in-rator-pos "(proc(x) -(x,1) 30)" 29) 60 | (apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29) 61 | (let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29) 62 | 63 | 64 | (nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1) 65 | (nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)" 66 | -1) 67 | 68 | (y-combinator-1 " 69 | let fix = proc (f) 70 | let d = proc (x) proc (z) ((f (x x)) z) 71 | in proc (n) ((f (d d)) n) 72 | in let 73 | t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4) 74 | in let times4 = (fix t4m) 75 | in (times4 3)" 12) 76 | )) 77 | ) -------------------------------------------------------------------------------- /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 | ;;;; function for automated testing ;;;; 15 | (provide test-all) 16 | (define (test-all) (run-all)) 17 | 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | (define run 23 | (lambda (string) 24 | (value-of-program (scan&parse string)))) 25 | 26 | ;; run-all : () -> Unspecified 27 | ;; runs all the tests in test-list, comparing the results with 28 | ;; equal-answer? 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 | ;; (run-one sym) runs the test whose name is sym 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 | -------------------------------------------------------------------------------- /chapter3/proc-lang/proc-rep/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | ;; data structures for proc-lang/proc-rep 4 | 5 | (require "lang.scm") ; for expression? 6 | 7 | (provide (all-defined-out)) ; 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 | ;; Page: 79 53 | (define proc? procedure?) 54 | 55 | ;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;; 56 | 57 | ;; example of a data type built without define-datatype 58 | 59 | (define empty-env-record 60 | (lambda () 61 | '())) 62 | 63 | (define extended-env-record 64 | (lambda (sym val old-env) 65 | (cons (list sym val) old-env))) 66 | 67 | (define empty-env-record? null?) 68 | 69 | (define environment? 70 | (lambda (x) 71 | (or (empty-env-record? x) 72 | (and (pair? x) 73 | (symbol? (car (car x))) 74 | (expval? (cadr (car x))) 75 | (environment? (cdr x)))))) 76 | 77 | (define extended-env-record->sym 78 | (lambda (r) 79 | (car (car r)))) 80 | 81 | (define extended-env-record->val 82 | (lambda (r) 83 | (cadr (car r)))) 84 | 85 | (define extended-env-record->old-env 86 | (lambda (r) 87 | (cdr r))) 88 | 89 | ) 90 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /chapter3/proc-lang/proc-rep/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | ;; interpreter for the PROC language, using the procedural 4 | ;; representation of procedures. 5 | 6 | ;; The \commentboxes are the latex code for inserting the rules into 7 | ;; the code in the book. These are too complicated to put here, see 8 | ;; the text, sorry. 9 | 10 | (require "drscheme-init.scm") 11 | 12 | (require "lang.scm") 13 | (require "data-structures.scm") 14 | (require "environments.scm") 15 | 16 | (provide value-of-program value-of) 17 | 18 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 19 | 20 | ;; value-of-program : Program -> ExpVal 21 | (define value-of-program 22 | (lambda (pgm) 23 | (cases program pgm 24 | (a-program (exp1) 25 | (value-of exp1 (init-env)))))) 26 | 27 | ;; value-of : Exp * Env -> ExpVal 28 | (define value-of 29 | (lambda (exp env) 30 | (cases expression exp 31 | 32 | ;\commentbox{ (value-of (const-exp \n{}) \r) = \n{}} 33 | (const-exp (num) (num-val num)) 34 | 35 | ;\commentbox{ (value-of (var-exp \x{}) \r) = (apply-env \r \x{})} 36 | (var-exp (var) (apply-env env var)) 37 | 38 | ;\commentbox{\diffspec} 39 | (diff-exp (exp1 exp2) 40 | (let ((val1 (value-of exp1 env)) 41 | (val2 (value-of exp2 env))) 42 | (let ((num1 (expval->num val1)) 43 | (num2 (expval->num val2))) 44 | (num-val 45 | (- num1 num2))))) 46 | 47 | ;\commentbox{\zerotestspec} 48 | (zero?-exp (exp1) 49 | (let ((val1 (value-of exp1 env))) 50 | (let ((num1 (expval->num val1))) 51 | (if (zero? num1) 52 | (bool-val #t) 53 | (bool-val #f))))) 54 | 55 | ;\commentbox{\ma{\theifspec}} 56 | (if-exp (exp1 exp2 exp3) 57 | (let ((val1 (value-of exp1 env))) 58 | (if (expval->bool val1) 59 | (value-of exp2 env) 60 | (value-of exp3 env)))) 61 | 62 | ;\commentbox{\ma{\theletspecsplit}} 63 | (let-exp (var exp1 body) 64 | (let ((val1 (value-of exp1 env))) 65 | (value-of body 66 | (extend-env var val1 env)))) 67 | 68 | (proc-exp (var body) 69 | (proc-val (procedure var body env))) 70 | 71 | (call-exp (rator rand) 72 | (let ((proc (expval->proc (value-of rator env))) 73 | (arg (value-of rand env))) 74 | (apply-procedure proc arg))) 75 | 76 | ))) 77 | 78 | 79 | ;; procedure : Var * Exp * Env -> Proc 80 | ;; Page: 79 81 | (define procedure 82 | (lambda (var body env) 83 | (lambda (val) 84 | (value-of body (extend-env var val env))))) 85 | 86 | ;; apply-procedure : Proc * ExpVal -> ExpVal 87 | ;; Page: 79 88 | (define apply-procedure 89 | (lambda (proc val) 90 | (proc val))) 91 | 92 | ) 93 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /chapter3/proc-lang/proc-rep/tests.scm: -------------------------------------------------------------------------------- 1 | (module tests mzscheme 2 | 3 | (provide test-list) 4 | 5 | ;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;; 6 | 7 | (define test-list 8 | '( 9 | 10 | ;; simple arithmetic 11 | (positive-const "11" 11) 12 | (negative-const "-33" -33) 13 | (simple-arith-1 "-(44,33)" 11) 14 | 15 | ;; nested arithmetic 16 | (nested-arith-left "-(-(44,33),22)" -11) 17 | (nested-arith-right "-(55, -(22,11))" 44) 18 | 19 | ;; simple variables 20 | (test-var-1 "x" 10) 21 | (test-var-2 "-(x,1)" 9) 22 | (test-var-3 "-(1,x)" -9) 23 | 24 | ;; simple unbound variables 25 | (test-unbound-var-1 "foo" error) 26 | (test-unbound-var-2 "-(x,foo)" error) 27 | 28 | ;; simple conditionals 29 | (if-true "if zero?(0) then 3 else 4" 3) 30 | (if-false "if zero?(1) then 3 else 4" 4) 31 | 32 | ;; test dynamic typechecking 33 | (no-bool-to-diff-1 "-(zero?(0),1)" error) 34 | (no-bool-to-diff-2 "-(1,zero?(0))" error) 35 | (no-int-to-if "if 1 then 2 else 3" error) 36 | 37 | ;; make sure that the test and both arms get evaluated 38 | ;; properly. 39 | (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3) 40 | (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4) 41 | 42 | ;; and make sure the other arm doesn't get evaluated. 43 | (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3) 44 | (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4) 45 | 46 | ;; simple let 47 | (simple-let-1 "let x = 3 in x" 3) 48 | 49 | ;; make sure the body and rhs get evaluated 50 | (eval-let-body "let x = 3 in -(x,1)" 2) 51 | (eval-let-rhs "let x = -(4,1) in -(x,1)" 2) 52 | 53 | ;; check nested let and shadowing 54 | (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1) 55 | (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4) 56 | (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2) 57 | 58 | ;; simple applications 59 | (apply-proc-in-rator-pos "(proc(x) -(x,1) 30)" 29) 60 | (apply-simple-proc "let f = proc (x) -(x,1) in (f 30)" 29) 61 | (let-to-proc-1 "(proc(f)(f 30) proc(x)-(x,1))" 29) 62 | 63 | 64 | (nested-procs "((proc (x) proc (y) -(x,y) 5) 6)" -1) 65 | (nested-procs2 "let f = proc(x) proc (y) -(x,y) in ((f -(10,5)) 6)" 66 | -1) 67 | 68 | (y-combinator-1 " 69 | let fix = proc (f) 70 | let d = proc (x) proc (z) ((f (x x)) z) 71 | in proc (n) ((f (d d)) n) 72 | in let 73 | t4m = proc (f) proc(x) if zero?(x) then 0 else -((f -(x,1)),-4) 74 | in let times4 = (fix t4m) 75 | in (times4 3)" 12) 76 | 77 | )) 78 | ) -------------------------------------------------------------------------------- /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 | ;;;; function for automated testing ;;;; 15 | (provide test-all) 16 | (define (test-all) (run-all)) 17 | 18 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 19 | 20 | ;; run : string -> expval 21 | 22 | (define run 23 | (lambda (string) 24 | (value-of-program (scan&parse string)))) 25 | 26 | ;; run-all : () -> unspecified 27 | 28 | ;; runs all the tests in test-list, comparing the results with 29 | ;; equal-answer? 30 | 31 | (define run-all 32 | (lambda () 33 | (run-tests! run equal-answer? test-list))) 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 | (else 45 | (eopl:error 'sloppy->expval 46 | "Can't convert sloppy value to expval: ~s" 47 | sloppy-val))))) 48 | 49 | ;; run-one : symbol -> expval 50 | 51 | ;; (run-one sym) runs the test whose name is sym 52 | 53 | (define run-one 54 | (lambda (test-name) 55 | (let ((the-test (assoc test-name test-list))) 56 | (cond 57 | ((assoc test-name test-list) 58 | => (lambda (test) 59 | (run (cadr test)))) 60 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 61 | 62 | ;; (run-all) 63 | 64 | ) 65 | 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /chapter4/call-by-need/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 | (require "store.scm") 8 | 9 | (provide init-env empty-env extend-env apply-env) 10 | 11 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 12 | 13 | ;; init-env : () -> Env 14 | ;; (init-env) builds an environment in which: 15 | ;; i is bound to a location containing the expressed value 1, 16 | ;; v is bound to a location containing the expressed value 5, and 17 | ;; x is bound to a location containing the expressed value 10. 18 | (define init-env 19 | (lambda () 20 | (extend-env 21 | 'i (newref (num-val 1)) 22 | (extend-env 23 | 'v (newref (num-val 5)) 24 | (extend-env 25 | 'x (newref (num-val 10)) 26 | (empty-env)))))) 27 | 28 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 29 | 30 | (define apply-env 31 | (lambda (env search-sym) 32 | (cases environment env 33 | (empty-env () 34 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 35 | (extend-env (bvar bval saved-env) 36 | (if (eqv? search-sym bvar) 37 | bval 38 | (apply-env saved-env search-sym))) 39 | (extend-env-rec* (p-names b-vars p-bodies saved-env) 40 | (cond 41 | ((location search-sym p-names) 42 | => (lambda (n) 43 | (newref 44 | (proc-val 45 | (procedure 46 | (list-ref b-vars n) 47 | (list-ref p-bodies n) 48 | env))))) 49 | (else (apply-env saved-env search-sym))))))) 50 | 51 | ;; location : Sym * Listof(Sym) -> Maybe(Int) 52 | ;; (location sym syms) returns the location of sym in syms or #f is 53 | ;; sym is not in syms. We can specify this as follows: 54 | ;; if (memv sym syms) 55 | ;; then (list-ref syms (location sym syms)) = sym 56 | ;; else (location sym syms) = #f 57 | (define location 58 | (lambda (sym syms) 59 | (cond 60 | ((null? syms) #f) 61 | ((eqv? sym (car syms)) 0) 62 | ((location sym (cdr syms)) 63 | => (lambda (n) 64 | (+ n 1))) 65 | (else #f)))) 66 | 67 | ) 68 | -------------------------------------------------------------------------------- /chapter4/call-by-need/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; language for the CALL-BY-NEED language. Based on MUTABLE-PAIRS 4 | ;; language. 5 | 6 | (require "drscheme-init.scm") 7 | 8 | (provide (all-defined-out)) 9 | 10 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 11 | 12 | (define the-lexical-spec 13 | '((whitespace (whitespace) skip) 14 | (comment ("%" (arbno (not #\newline))) skip) 15 | (identifier 16 | (letter (arbno (or letter digit "_" "-" "?"))) 17 | symbol) 18 | (number (digit (arbno digit)) number) 19 | (number ("-" digit (arbno digit)) number) 20 | )) 21 | 22 | (define the-grammar 23 | '((program (expression) a-program) 24 | 25 | (expression (number) const-exp) 26 | (expression 27 | ("-" "(" expression "," expression ")") 28 | diff-exp) 29 | 30 | (expression 31 | ("zero?" "(" expression ")") 32 | zero?-exp) 33 | 34 | (expression 35 | ("if" expression "then" expression "else" expression) 36 | if-exp) 37 | 38 | (expression (identifier) var-exp) 39 | 40 | (expression 41 | ("let" identifier "=" expression "in" expression) 42 | let-exp) 43 | 44 | (expression 45 | ("proc" "(" identifier ")" expression) 46 | proc-exp) 47 | 48 | (expression 49 | ("(" expression expression ")") 50 | call-exp) 51 | 52 | (expression 53 | ("letrec" 54 | (arbno identifier "(" identifier ")" "=" expression) 55 | "in" expression) 56 | letrec-exp) 57 | 58 | (expression 59 | ("begin" expression (arbno ";" expression) "end") 60 | begin-exp) 61 | 62 | (expression 63 | ("set" identifier "=" expression) 64 | assign-exp) 65 | 66 | (expression 67 | ("newpair" "(" expression "," expression ")") 68 | newpair-exp) 69 | 70 | (expression 71 | ("left" "(" expression ")") 72 | left-exp) 73 | 74 | (expression 75 | ("setleft" expression "=" expression) 76 | setleft-exp) 77 | 78 | (expression 79 | ("right" "(" expression ")") 80 | right-exp) 81 | 82 | (expression 83 | ("setright" expression "=" expression) 84 | setright-exp) 85 | 86 | )) 87 | 88 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 89 | 90 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 91 | 92 | (define show-the-datatypes 93 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 94 | 95 | (define scan&parse 96 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 97 | 98 | (define just-scan 99 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 100 | 101 | ) 102 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /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-out "pairval1.scm")) 6 | 7 | ;; or 8 | (require "pairval2.scm") 9 | (provide (all-from-out "pairval2.scm")) 10 | 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /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 for book test ;;; 15 | (provide test-all) 16 | (define (test-all) 17 | (run-all)) 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | (define run 23 | (lambda (string) 24 | (value-of-program (scan&parse string)))) 25 | 26 | ;; run-all : () -> Unspecified 27 | 28 | ;; runs all the tests in test-list, comparing the results with 29 | ;; equal-answer? 30 | 31 | (define run-all 32 | (lambda () 33 | (run-tests! run equal-answer? test-list))) 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 | (else 45 | (eopl:error 'sloppy->expval 46 | "Can't convert sloppy value to expval: ~s" 47 | sloppy-val))))) 48 | 49 | ;; run-one : Sym -> ExpVal 50 | 51 | ;; (run-one sym) runs the test whose name is sym 52 | 53 | (define run-one 54 | (lambda (test-name) 55 | (let ((the-test (assoc test-name test-list))) 56 | (cond 57 | ((assoc test-name test-list) 58 | => (lambda (test) 59 | (run (cadr test)))) 60 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 61 | 62 | ;; (run-all) 63 | 64 | ) 65 | 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /chapter4/call-by-reference/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 : () -> Env 10 | ;; (init-env) builds an environment in which: 11 | ;; i is bound to a location containing the expressed value 1, 12 | ;; v is bound to a location containing the expressed value 5, and 13 | ;; x is bound to a location containing the expressed value 10. 14 | (define init-env 15 | (lambda () 16 | (extend-env 17 | 'i (newref (num-val 1)) 18 | (extend-env 19 | 'v (newref (num-val 5)) 20 | (extend-env 21 | 'x (newref (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-names b-vars p-bodies saved-env) 36 | (cond 37 | ((location search-sym p-names) 38 | => (lambda (n) 39 | (newref 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 | 48 | ;; location : Sym * Listof(Sym) -> Maybe(Int) 49 | ;; (location sym syms) returns the location of sym in syms or #f is 50 | ;; sym is not in syms. We can specify this as follows: 51 | ;; if (memv sym syms) 52 | ;; then (list-ref syms (location sym syms)) = sym 53 | ;; else (location sym syms) = #f 54 | (define location 55 | (lambda (sym syms) 56 | (cond 57 | ((null? syms) #f) 58 | ((eqv? sym (car syms)) 0) 59 | ((location sym (cdr syms)) 60 | => (lambda (n) 61 | (+ n 1))) 62 | (else #f)))) 63 | 64 | ) 65 | -------------------------------------------------------------------------------- /chapter4/call-by-reference/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; language for CALL-BY-REFERENCE. Based on MUTABLE-PAIRS. 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 | (arbno identifier "(" identifier ")" "=" expression) 54 | "in" expression) 55 | letrec-exp) 56 | 57 | (expression 58 | ("begin" expression (arbno ";" expression) "end") 59 | begin-exp) 60 | 61 | (expression 62 | ("set" identifier "=" expression) 63 | assign-exp) 64 | 65 | (expression 66 | ("newpair" "(" expression "," expression ")") 67 | newpair-exp) 68 | 69 | (expression 70 | ("left" "(" expression ")") 71 | left-exp) 72 | 73 | (expression 74 | ("setleft" expression "=" expression) 75 | setleft-exp) 76 | 77 | (expression 78 | ("right" "(" expression ")") 79 | right-exp) 80 | 81 | (expression 82 | ("setright" expression "=" expression) 83 | setright-exp) 84 | 85 | )) 86 | 87 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 88 | 89 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 90 | 91 | (define show-the-datatypes 92 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 93 | 94 | (define scan&parse 95 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 96 | 97 | (define just-scan 98 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 99 | 100 | ) 101 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /chapter4/call-by-reference/pairval2.scm: -------------------------------------------------------------------------------- 1 | (module pairval2 (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") 5 | 6 | (provide (all-defined-out)) 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 | -------------------------------------------------------------------------------- /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-out "pairval1.scm")) 6 | 7 | ;; or 8 | (require "pairval2.scm") 9 | (provide (all-from-out "pairval2.scm")) 10 | 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /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 for book test ;;; 15 | (provide test-all) 16 | (define (test-all) 17 | (run-all)) 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | 23 | (define run 24 | (lambda (string) 25 | (value-of-program (scan&parse string)))) 26 | 27 | ;; run-all : () -> Unspecified 28 | 29 | ;; runs all the tests in test-list, comparing the results with 30 | ;; equal-answer? 31 | 32 | (define run-all 33 | (lambda () 34 | (run-tests! run equal-answer? test-list))) 35 | 36 | (define equal-answer? 37 | (lambda (ans correct-ans) 38 | (equal? ans (sloppy->expval correct-ans)))) 39 | 40 | (define sloppy->expval 41 | (lambda (sloppy-val) 42 | (cond 43 | ((number? sloppy-val) (num-val sloppy-val)) 44 | ((boolean? sloppy-val) (bool-val sloppy-val)) 45 | (else 46 | (eopl:error 'sloppy->expval 47 | "Can't convert sloppy value to expval: ~s" 48 | sloppy-val))))) 49 | 50 | ;; run-one : Sym -> ExpVal 51 | 52 | ;; (run-one sym) runs the test whose name is sym 53 | 54 | (define run-one 55 | (lambda (test-name) 56 | (let ((the-test (assoc test-name test-list))) 57 | (cond 58 | ((assoc test-name test-list) 59 | => (lambda (test) 60 | (run (cadr test)))) 61 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 62 | 63 | ;; (run-all) 64 | 65 | ) 66 | 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /chapter4/explicit-refs/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | (require "store.scm") ; for reference? 5 | 6 | (provide (all-defined-out)) ; too many things to list 7 | 8 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 9 | 10 | ;;; an expressed value is either a number, a boolean, a procval, or a 11 | ;;; reference. 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 | (ref-val 21 | (ref reference?)) 22 | ) 23 | 24 | ;;; extractors: 25 | 26 | (define expval->num 27 | (lambda (v) 28 | (cases expval v 29 | (num-val (num) num) 30 | (else (expval-extractor-error 'num v))))) 31 | 32 | (define expval->bool 33 | (lambda (v) 34 | (cases expval v 35 | (bool-val (bool) bool) 36 | (else (expval-extractor-error 'bool v))))) 37 | 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->ref 45 | (lambda (v) 46 | (cases expval v 47 | (ref-val (ref) ref) 48 | (else (expval-extractor-error 'reference v))))) 49 | 50 | (define expval-extractor-error 51 | (lambda (variant value) 52 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 53 | variant value))) 54 | 55 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 56 | 57 | (define-datatype proc proc? 58 | (procedure 59 | (bvar symbol?) 60 | (body expression?) 61 | (env environment?))) 62 | 63 | (define-datatype environment environment? 64 | (empty-env) 65 | (extend-env 66 | (bvar symbol?) 67 | (bval expval?) 68 | (saved-env environment?)) 69 | (extend-env-rec* 70 | (proc-names (list-of symbol?)) 71 | (b-vars (list-of symbol?)) 72 | (proc-bodies (list-of expression?)) 73 | (saved-env environment?))) 74 | 75 | ;; env->list : Env -> List 76 | ;; used for pretty-printing and debugging 77 | (define env->list 78 | (lambda (env) 79 | (cases environment env 80 | (empty-env () '()) 81 | (extend-env (sym val saved-env) 82 | (cons 83 | (list sym (expval->printable val)) 84 | (env->list saved-env))) 85 | (extend-env-rec* (p-names b-vars p-bodies saved-env) 86 | (cons 87 | (list 'letrec p-names '...) 88 | (env->list saved-env)))))) 89 | 90 | ;; expval->printable : ExpVal -> List 91 | ;; returns a value like its argument, except procedures get cleaned 92 | ;; up with env->list 93 | (define expval->printable 94 | (lambda (val) 95 | (cases expval val 96 | (proc-val (p) 97 | (cases proc p 98 | (procedure (var body saved-env) 99 | (list 'procedure var '... (env->list saved-env))))) 100 | (else val)))) 101 | 102 | 103 | ) 104 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter4/explicit-refs/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; language for EXPLICIT-REFS 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 | (arbno identifier "(" identifier ")" "=" expression) 54 | "in" expression) 55 | letrec-exp) 56 | 57 | ;; new for explicit-refs 58 | 59 | (expression 60 | ("begin" expression (arbno ";" expression) "end") 61 | begin-exp) 62 | 63 | (expression 64 | ("newref" "(" expression ")") 65 | newref-exp) 66 | 67 | (expression 68 | ("deref" "(" expression ")") 69 | deref-exp) 70 | 71 | (expression 72 | ("setref" "(" expression "," expression ")") 73 | setref-exp) 74 | 75 | )) 76 | 77 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 78 | 79 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 80 | 81 | (define show-the-datatypes 82 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 83 | 84 | (define scan&parse 85 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 86 | 87 | (define just-scan 88 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 89 | 90 | ) 91 | -------------------------------------------------------------------------------- /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 for book test ;;; 15 | (provide test-all) 16 | (define (test-all) 17 | (run-all)) 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | 23 | (define run 24 | (lambda (string) 25 | (value-of-program (scan&parse string)))) 26 | 27 | ;; run-all : () -> Unspecified 28 | 29 | ;; runs all the tests in test-list, comparing the results with 30 | ;; equal-answer? 31 | 32 | (define run-all 33 | (lambda () 34 | (run-tests! run equal-answer? test-list))) 35 | 36 | (define equal-answer? 37 | (lambda (ans correct-ans) 38 | (equal? ans (sloppy->expval correct-ans)))) 39 | 40 | (define sloppy->expval 41 | (lambda (sloppy-val) 42 | (cond 43 | ((number? sloppy-val) (num-val sloppy-val)) 44 | ((boolean? sloppy-val) (bool-val sloppy-val)) 45 | (else 46 | (eopl:error 'sloppy->expval 47 | "Can't convert sloppy value to expval: ~s" 48 | sloppy-val))))) 49 | 50 | ;; run-one : Sym -> ExpVal 51 | 52 | ;; (run-one sym) runs the test whose name is sym 53 | 54 | (define run-one 55 | (lambda (test-name) 56 | (let ((the-test (assoc test-name test-list))) 57 | (cond 58 | ((assoc test-name test-list) 59 | => (lambda (test) 60 | (run (cadr test)))) 61 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 62 | 63 | ;; (run-all) 64 | 65 | ) 66 | 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /chapter4/implicit-refs/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | (require "store.scm") ; for reference? 5 | 6 | (provide (all-defined-out)) ; too many things to list 7 | 8 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 9 | 10 | ;;; an expressed value is either a number, a boolean, a procval, or a 11 | ;;; reference. 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 | (ref-val 21 | (ref reference?)) 22 | ) 23 | 24 | ;;; extractors: 25 | 26 | (define expval->num 27 | (lambda (v) 28 | (cases expval v 29 | (num-val (num) num) 30 | (else (expval-extractor-error 'num v))))) 31 | 32 | (define expval->bool 33 | (lambda (v) 34 | (cases expval v 35 | (bool-val (bool) bool) 36 | (else (expval-extractor-error 'bool v))))) 37 | 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->ref 45 | (lambda (v) 46 | (cases expval v 47 | (ref-val (ref) ref) 48 | (else (expval-extractor-error 'reference v))))) 49 | 50 | (define expval-extractor-error 51 | (lambda (variant value) 52 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 53 | variant value))) 54 | 55 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 56 | 57 | (define-datatype proc proc? 58 | (procedure 59 | (bvar symbol?) 60 | (body expression?) 61 | (env environment?))) 62 | 63 | (define-datatype environment environment? 64 | (empty-env) 65 | (extend-env 66 | (bvar symbol?) 67 | (bval reference?) ; new for implicit-refs 68 | (saved-env environment?)) 69 | (extend-env-rec* 70 | (proc-names (list-of symbol?)) 71 | (b-vars (list-of symbol?)) 72 | (proc-bodies (list-of expression?)) 73 | (saved-env environment?))) 74 | 75 | ;; env->list : Env -> List 76 | ;; used for pretty-printing and debugging 77 | (define env->list 78 | (lambda (env) 79 | (cases environment env 80 | (empty-env () '()) 81 | (extend-env (sym val saved-env) 82 | (cons 83 | (list sym val) ; val is a denoted value-- a 84 | ; reference. 85 | (env->list saved-env))) 86 | (extend-env-rec* (p-names b-vars p-bodies saved-env) 87 | (cons 88 | (list 'letrec p-names '...) 89 | (env->list saved-env)))))) 90 | 91 | ;; expval->printable : ExpVal -> List 92 | ;; returns a value like its argument, except procedures get cleaned 93 | ;; up with env->list 94 | (define expval->printable 95 | (lambda (val) 96 | (cases expval val 97 | (proc-val (p) 98 | (cases proc p 99 | (procedure (var body saved-env) 100 | (list 'procedure var '... (env->list saved-env))))) 101 | (else val)))) 102 | 103 | ) 104 | -------------------------------------------------------------------------------- /chapter4/implicit-refs/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 : () -> Env 10 | ;; (init-env) builds an environment in which: 11 | ;; i is bound to a location containing the expressed value 1, 12 | ;; v is bound to a location containing the expressed value 5, and 13 | ;; x is bound to a location containing the expressed value 10. 14 | (define init-env 15 | (lambda () 16 | (extend-env 17 | 'i (newref (num-val 1)) 18 | (extend-env 19 | 'v (newref (num-val 5)) 20 | (extend-env 21 | 'x (newref (num-val 10)) 22 | (empty-env)))))) 23 | 24 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 25 | 26 | (define apply-env 27 | (lambda (env search-var) 28 | (cases environment env 29 | (empty-env () 30 | (eopl:error 'apply-env "No binding for ~s" search-var)) 31 | (extend-env (bvar bval saved-env) 32 | (if (eqv? search-var bvar) 33 | bval 34 | (apply-env saved-env search-var))) 35 | (extend-env-rec* (p-names b-vars p-bodies saved-env) 36 | (let ((n (location search-var p-names))) 37 | ;; n : (maybe int) 38 | (if n 39 | (newref 40 | (proc-val 41 | (procedure 42 | (list-ref b-vars n) 43 | (list-ref p-bodies n) 44 | env))) 45 | (apply-env saved-env search-var))))))) 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 | ) 64 | -------------------------------------------------------------------------------- /chapter4/implicit-refs/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; language for IMPLICIT-REFS 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 | (arbno identifier "(" identifier ")" "=" expression) 54 | "in" expression) 55 | letrec-exp) 56 | 57 | (expression 58 | ("begin" expression (arbno ";" expression) "end") 59 | begin-exp) 60 | 61 | ;; new for implicit-refs 62 | 63 | (expression 64 | ("set" identifier "=" expression) 65 | assign-exp) 66 | 67 | )) 68 | 69 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 70 | 71 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 72 | 73 | (define show-the-datatypes 74 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 75 | 76 | (define scan&parse 77 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 78 | 79 | (define just-scan 80 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 81 | 82 | ) 83 | -------------------------------------------------------------------------------- /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 for book test ;;; 15 | (provide test-all) 16 | (define (test-all) 17 | (run-all)) 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | 23 | (define run 24 | (lambda (string) 25 | (value-of-program (scan&parse string)))) 26 | 27 | ;; run-all : () -> Unspecified 28 | 29 | ;; runs all the tests in test-list, comparing the results with 30 | ;; equal-answer? 31 | 32 | (define run-all 33 | (lambda () 34 | (run-tests! run equal-answer? test-list))) 35 | 36 | (define equal-answer? 37 | (lambda (ans correct-ans) 38 | (equal? ans (sloppy->expval correct-ans)))) 39 | 40 | (define sloppy->expval 41 | (lambda (sloppy-val) 42 | (cond 43 | ((number? sloppy-val) (num-val sloppy-val)) 44 | ((boolean? sloppy-val) (bool-val sloppy-val)) 45 | (else 46 | (eopl:error 'sloppy->expval 47 | "Can't convert sloppy value to expval: ~s" 48 | sloppy-val))))) 49 | 50 | ;; run-one : Sym -> ExpVal 51 | ;; (run-one sym) runs the test whose name is sym 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /chapter4/mutable-pairs/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; language for MUTABLE-PAIRS 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 | (arbno identifier "(" identifier ")" "=" expression) 54 | "in" expression) 55 | letrec-exp) 56 | 57 | (expression 58 | ("begin" expression (arbno ";" expression) "end") 59 | begin-exp) 60 | 61 | (expression 62 | ("set" identifier "=" expression) 63 | assign-exp) 64 | 65 | ;; new for mutable-pairs 66 | 67 | (expression 68 | ("newpair" "(" expression "," expression ")") 69 | newpair-exp) 70 | 71 | (expression 72 | ("left" "(" expression ")") 73 | left-exp) 74 | 75 | (expression 76 | ("setleft" expression "=" expression) 77 | setleft-exp) 78 | 79 | (expression 80 | ("right" "(" expression ")") 81 | right-exp) 82 | 83 | (expression 84 | ("setright" expression "=" expression) 85 | setright-exp) 86 | 87 | )) 88 | 89 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 90 | 91 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 92 | 93 | (define show-the-datatypes 94 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 95 | 96 | (define scan&parse 97 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 98 | 99 | (define just-scan 100 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 101 | 102 | ) 103 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /chapter4/mutable-pairs/pairval2.scm: -------------------------------------------------------------------------------- 1 | (module pairval2 (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "store.scm") 5 | 6 | (provide (all-defined-out)) 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 | -------------------------------------------------------------------------------- /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-out "pairval1.scm")) 6 | 7 | ;; or 8 | (require "pairval2.scm") 9 | (provide (all-from-out "pairval2.scm")) 10 | 11 | ) 12 | 13 | -------------------------------------------------------------------------------- /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 for book test ;;; 15 | (provide test-all) 16 | (define (test-all) 17 | (run-all)) 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | 23 | (define run 24 | (lambda (string) 25 | (value-of-program (scan&parse string)))) 26 | 27 | ;; run-all : () -> Unspecified 28 | 29 | ;; runs all the tests in test-list, comparing the results with 30 | ;; equal-answer? 31 | 32 | (define run-all 33 | (lambda () 34 | (run-tests! run equal-answer? test-list))) 35 | 36 | (define equal-answer? 37 | (lambda (ans correct-ans) 38 | (equal? ans (sloppy->expval correct-ans)))) 39 | 40 | (define sloppy->expval 41 | (lambda (sloppy-val) 42 | (cond 43 | ((number? sloppy-val) (num-val sloppy-val)) 44 | ((boolean? sloppy-val) (bool-val sloppy-val)) 45 | (else 46 | (eopl:error 'sloppy->expval 47 | "Can't convert sloppy value to expval: ~s" 48 | sloppy-val))))) 49 | 50 | ;; run-one : Sym -> ExpVal 51 | 52 | ;; (run-one sym) runs the test whose name is sym 53 | 54 | (define run-one 55 | (lambda (test-name) 56 | (let ((the-test (assoc test-name test-list))) 57 | (cond 58 | ((assoc test-name test-list) 59 | => (lambda (test) 60 | (run (cadr test)))) 61 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 62 | 63 | ;; (run-all) 64 | 65 | ) 66 | 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /chapter5/exceptions/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined-out)) ; too many things to list 6 | 7 | ;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;; 8 | 9 | ;;; an expressed value is either a number, a boolean, a procval, or a 10 | ;;; list of expvals. 11 | 12 | (define-datatype expval expval? 13 | (num-val 14 | (value number?)) 15 | (bool-val 16 | (boolean boolean?)) 17 | (proc-val 18 | (proc proc?)) 19 | (list-val 20 | (lst (list-of expval?)))) 21 | 22 | ;;; extractors: 23 | 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 | (define expval->bool 31 | (lambda (v) 32 | (cases expval v 33 | (bool-val (bool) bool) 34 | (else (expval-extractor-error 'bool v))))) 35 | 36 | (define expval->proc 37 | (lambda (v) 38 | (cases expval v 39 | (proc-val (proc) proc) 40 | (else (expval-extractor-error 'proc v))))) 41 | 42 | (define expval->list 43 | (lambda (v) 44 | (cases expval v 45 | (list-val (lst) lst) 46 | (else (expval-extractor-error 'list v))))) 47 | 48 | (define expval-extractor-error 49 | (lambda (variant value) 50 | (eopl:error 'expval-extractors "Looking for a ~s, found ~s" 51 | variant value))) 52 | 53 | ;; ;;;;;;;;;;;;;;;; continuations ;;;;;;;;;;;;;;;; 54 | 55 | ;; moved to interp.scm 56 | 57 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 58 | 59 | (define-datatype proc proc? 60 | (procedure 61 | (bvar symbol?) 62 | (body expression?) 63 | (env environment?))) 64 | 65 | ;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;; 66 | 67 | ;;; replaced by custom environment structure in environments.scm. 68 | ;;; This represents an environment as an alist ((id rhs) ...) 69 | ;;; where rhs is either an expval or a list (bvar body) 70 | ;;; expval is for extend-env; the list is for extend-env-rec. 71 | 72 | ;;; this representation is designed to make the printed representation 73 | ;;; of the environment more readable. 74 | 75 | ;;; The code for this is in environments.scm, but we need environment? 76 | ;;; for define-datatype proc, so we write an appoximation: 77 | 78 | (define environment? 79 | (list-of 80 | (lambda (p) 81 | (and 82 | (pair? p) 83 | (symbol? (car p)))))) 84 | 85 | ) 86 | -------------------------------------------------------------------------------- /chapter5/exceptions/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | (provide init-env empty-env extend-env extend-env-rec 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 | ;;; represent environment as an alist ((id rhs) ...) 27 | 28 | ;;; rhs is either an expval or a list (bvar body) 29 | ;;; expval is for extend-env; the list is for extend-env-rec. 30 | 31 | ;;; this representation is designed to make the printed representation 32 | ;;; of the environment more readable. 33 | 34 | (define empty-env 35 | (lambda () 36 | '())) 37 | 38 | (define empty-env? 39 | (lambda (x) (null? x))) 40 | 41 | (define extend-env 42 | (lambda (sym val old-env) 43 | (cons (list sym val) old-env))) 44 | 45 | (define extend-env-rec 46 | (lambda (p-name b-var p-body saved-env) 47 | (cons 48 | (list p-name b-var p-body) 49 | saved-env))) 50 | 51 | (define apply-env 52 | (lambda (env search-sym) 53 | (if (null? env) 54 | (eopl:error 'apply-env "No binding for ~s" search-sym) 55 | (let* ((binding (car env)) 56 | (id (list-ref binding 0)) 57 | (expval-or-bvar (list-ref binding 1))) 58 | (cond 59 | ((not (eqv? search-sym id)) 60 | (apply-env (cdr env) search-sym)) 61 | ((not (symbol? expval-or-bvar)) 62 | ;; this was built by extend-env 63 | expval-or-bvar) 64 | (else 65 | ;; this was built by extend-env-rec 66 | (let ((bvar (cadr binding)) 67 | (body (caddr binding))) 68 | (proc-val (procedure bvar body env))))))))) 69 | 70 | ) -------------------------------------------------------------------------------- /chapter5/exceptions/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; grammar for the EXCEPTIONS language. This is a somewhat cut-down 4 | ;; version of the LETREC language. 5 | 6 | ;; exercise: allow the "list" operator to take expressions instead 7 | ;; of just numbers. 8 | 9 | (require "drscheme-init.scm") 10 | 11 | (provide (all-defined-out)) 12 | 13 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 14 | 15 | (define the-lexical-spec 16 | '((whitespace (whitespace) skip) 17 | (comment ("%" (arbno (not #\newline))) skip) 18 | (identifier 19 | (letter (arbno (or letter digit "_" "-" "?"))) 20 | symbol) 21 | (number (digit (arbno digit)) number) 22 | (number ("-" digit (arbno digit)) number) 23 | )) 24 | 25 | (define the-grammar 26 | '((program (expression) a-program) 27 | 28 | (expression (number) const-exp) 29 | 30 | (expression 31 | ("-" "(" expression "," expression ")") 32 | diff-exp) 33 | 34 | (expression 35 | ("if" expression "then" expression "else" expression) 36 | if-exp) 37 | 38 | (expression (identifier) var-exp) 39 | 40 | (expression 41 | ("proc" "(" identifier ")" expression) 42 | proc-exp) 43 | 44 | (expression 45 | ("(" expression expression ")") 46 | call-exp) 47 | 48 | (expression 49 | ("let" identifier "=" expression "in" expression) 50 | let-exp) 51 | 52 | (expression 53 | ("letrec" 54 | identifier "(" identifier ")" "=" expression 55 | "in" expression) 56 | letrec-exp) 57 | 58 | ;; Lists. We will have lists of literal numbers only. 59 | 60 | (expression 61 | ("list" "(" (separated-list number ",") ")") 62 | const-list-exp) 63 | 64 | (expression 65 | (unary-op "(" expression ")") 66 | unop-exp) 67 | 68 | (expression 69 | ("try" expression "catch" "(" identifier ")" expression) 70 | try-exp) 71 | 72 | (expression 73 | ("raise" expression) 74 | raise-exp) 75 | 76 | (unary-op ("null?") null?-unop) 77 | (unary-op ("car") car-unop) 78 | (unary-op ("cdr" ) cdr-unop) 79 | (unary-op ("zero?") zero?-unop) 80 | 81 | )) 82 | 83 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 84 | 85 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 86 | 87 | (define show-the-datatypes 88 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 89 | 90 | (define scan&parse 91 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 92 | 93 | (define just-scan 94 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 95 | 96 | ) 97 | -------------------------------------------------------------------------------- /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 for book test ;;; 16 | (provide test-all) 17 | (define (test-all) 18 | (run-all)) 19 | 20 | 21 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 22 | 23 | ;; run : String -> ExpVal 24 | 25 | (define run 26 | (lambda (string) 27 | (value-of-program (scan&parse string)))) 28 | 29 | ;; run-all : () -> Unspecified 30 | 31 | ;; runs all the tests in test-list, comparing the results with 32 | ;; equal-answer? 33 | 34 | (define run-all 35 | (lambda () 36 | (run-tests! run equal-answer? test-list))) 37 | 38 | (define equal-answer? 39 | (lambda (ans correct-ans) 40 | (equal? ans (sloppy->expval correct-ans)))) 41 | 42 | (define sloppy->expval 43 | (lambda (sloppy-val) 44 | (cond 45 | ((number? sloppy-val) (num-val sloppy-val)) 46 | ((boolean? sloppy-val) (bool-val sloppy-val)) 47 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 48 | (else 49 | (eopl:error 'sloppy->expval 50 | "Can't convert sloppy value to expval: ~s" 51 | sloppy-val))))) 52 | 53 | ;; run-one : Sym -> ExpVal 54 | 55 | ;; (run-one sym) runs the test whose name is sym 56 | 57 | (define run-one 58 | (lambda (test-name) 59 | (let ((the-test (assoc test-name test-list))) 60 | (cond 61 | ((assoc test-name test-list) 62 | => (lambda (test) 63 | (run (cadr test)))) 64 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 65 | 66 | ;; make sure this is initially off. 67 | (trace-apply-procedure #f) 68 | 69 | ;; (run-all) 70 | 71 | ;; to generate the big trace in the text, say 72 | ;; (trace-apply-procedure #t) 73 | ;; (run-one 'text-example-1.2) 74 | 75 | ) 76 | 77 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /chapter5/letrec-lang/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined-out)) ; 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 | ;;;;;;;;;;;;;;;; continuations ;;;;;;;;;;;;;;;; 45 | 46 | ;; Page: 148 47 | (define identifier? symbol?) 48 | 49 | (define-datatype continuation continuation? 50 | (end-cont) 51 | (zero1-cont 52 | (saved-cont continuation?)) 53 | (let-exp-cont 54 | (var identifier?) 55 | (body expression?) 56 | (saved-env environment?) 57 | (saved-cont continuation?)) 58 | (if-test-cont 59 | (exp2 expression?) 60 | (exp3 expression?) 61 | (saved-env environment?) 62 | (saved-cont continuation?)) 63 | (diff1-cont 64 | (exp2 expression?) 65 | (saved-env environment?) 66 | (saved-cont continuation?)) 67 | (diff2-cont 68 | (val1 expval?) 69 | (saved-cont continuation?)) 70 | (rator-cont 71 | (rand expression?) 72 | (saved-env environment?) 73 | (saved-cont continuation?)) 74 | (rand-cont 75 | (val1 expval?) 76 | (saved-cont continuation?))) 77 | 78 | ;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;; 79 | 80 | (define-datatype proc proc? 81 | (procedure 82 | (bvar symbol?) 83 | (body expression?) 84 | (env environment?))) 85 | 86 | ;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;; 87 | 88 | (define-datatype environment environment? 89 | (empty-env) 90 | (extend-env 91 | (bvar symbol?) 92 | (bval expval?) 93 | (saved-env environment?)) 94 | (extend-env-rec 95 | (p-name symbol?) 96 | (b-var symbol?) 97 | (p-body expression?) 98 | (saved-env environment?))) 99 | 100 | ) 101 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter5/letrec-lang/eopl-without-exp.scm: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; remove "exp" from the eopl language level, because we use it as 4 | ;; a mutable variable. 5 | 6 | (require (lib "eopl.ss" "eopl")) 7 | (provide (except-out (all-from-out (lib "eopl.ss" "eopl")) exp)) 8 | 9 | -------------------------------------------------------------------------------- /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-out)) 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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-out)) 13 | (provide (all-from-out "interp.scm")) 14 | (provide (all-from-out "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 | -------------------------------------------------------------------------------- /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-in interp- "top-interp.scm")) 8 | (require (prefix-in 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 | ;;; interface for book test ;;; 18 | (provide test-all) 19 | (define (test-all) 20 | (run-all)) 21 | 22 | 23 | ) 24 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter5/thread-lang/queues.scm: -------------------------------------------------------------------------------- 1 | (module queues (lib "eopl.ss" "eopl") 2 | 3 | (provide (all-defined-out)) 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 | ) 28 | -------------------------------------------------------------------------------- /chapter5/thread-lang/scheduler.scm: -------------------------------------------------------------------------------- 1 | (module scheduler (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "queues.scm") 5 | (require "data-structures.scm") ; for continuation? 6 | (require "lang.scm") ; for expval? 7 | 8 | (provide 9 | initialize-scheduler! 10 | set-final-answer! 11 | 12 | time-expired? 13 | decrement-timer! 14 | 15 | place-on-ready-queue! 16 | run-next-thread 17 | 18 | ) 19 | 20 | ;;;;;;;;;;;;;;;; the state ;;;;;;;;;;;;;;;; 21 | 22 | ;; components of the scheduler state: 23 | 24 | (define the-ready-queue 'uninitialized) 25 | (define the-final-answer 'uninitialized) 26 | 27 | (define the-max-time-slice 'uninitialized) 28 | (define the-time-remaining 'uninitialized) 29 | 30 | ;; initialize-scheduler! : Int -> Unspecified 31 | (define initialize-scheduler! 32 | (lambda (ticks) 33 | (set! the-ready-queue (empty-queue)) 34 | (set! the-final-answer 'uninitialized) 35 | (set! the-max-time-slice ticks) 36 | (set! the-time-remaining the-max-time-slice) 37 | )) 38 | 39 | ;;;;;;;;;;;;;;;; the final answer ;;;;;;;;;;;;;;;; 40 | 41 | ;; place-on-ready-queue! : Thread -> Unspecified 42 | ;; Page: 184 43 | (define place-on-ready-queue! 44 | (lambda (th) 45 | (set! the-ready-queue 46 | (enqueue the-ready-queue th)))) 47 | 48 | ;; run-next-thread : () -> FinalAnswer 49 | ;; Page: 184 50 | (define run-next-thread 51 | (lambda () 52 | (if (empty? the-ready-queue) 53 | the-final-answer 54 | (dequeue the-ready-queue 55 | (lambda (first-ready-thread other-ready-threads) 56 | (set! the-ready-queue other-ready-threads) 57 | (set! the-time-remaining the-max-time-slice) 58 | (first-ready-thread) 59 | ))))) 60 | 61 | ;; set-final-answer! : ExpVal -> Unspecified 62 | ;; Page: 184 63 | (define set-final-answer! 64 | (lambda (val) 65 | (set! the-final-answer val))) 66 | 67 | ;; time-expired? : () -> Bool 68 | ;; Page: 184 69 | (define time-expired? 70 | (lambda () 71 | (zero? the-time-remaining))) 72 | 73 | ;; decrement-timer! : () -> Unspecified 74 | ;; Page: 184 75 | (define decrement-timer! 76 | (lambda () 77 | (set! the-time-remaining (- the-time-remaining 1)))) 78 | 79 | ) 80 | -------------------------------------------------------------------------------- /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-out)) 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 | (when 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 | ) 62 | -------------------------------------------------------------------------------- /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 | ;;; interface for book test ;;; 8 | (provide test-all) 9 | (define (test-all) 10 | (run-all 50)) 11 | 12 | (require "drscheme-init.scm") 13 | (require "data-structures.scm") 14 | (require "lang.scm") ; for scan&parse 15 | (require "interp.scm") ; for value-of-program 16 | (require "tests.scm") ; for test-list 17 | 18 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 19 | 20 | (define run 21 | (lambda (timeslice string) 22 | (value-of-program timeslice (scan&parse string)))) 23 | 24 | (define run-all 25 | (lambda (timeslice) 26 | (run-tests! 27 | (lambda (string) (run timeslice string)) 28 | equal-answer? test-list))) 29 | 30 | (define run-one 31 | (lambda (timeslice test-name) 32 | (let ((the-test (assoc test-name test-list))) 33 | (cond 34 | ((assoc test-name test-list) 35 | => (lambda (test) 36 | (run timeslice (cadr test)))) 37 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 38 | 39 | (define equal-answer? 40 | (lambda (ans correct-ans) 41 | (equal? ans (sloppy->expval correct-ans)))) 42 | 43 | (define sloppy->expval 44 | (lambda (sloppy-val) 45 | (cond 46 | ((number? sloppy-val) (num-val sloppy-val)) 47 | ((boolean? sloppy-val) (bool-val sloppy-val)) 48 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 49 | (else 50 | (eopl:error 'sloppy->expval 51 | "Can't convert sloppy value to expval: ~s" 52 | sloppy-val))))) 53 | 54 | 55 | ;; (stop-after-first-error #t) 56 | ;; (run-all 5) 57 | ;; (run-one 1000 'producer-consumer) 58 | 59 | ) 60 | 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /chapter6/cps-lang/cps-in-lang.scm: -------------------------------------------------------------------------------- 1 | (module cps-in-lang (lib "eopl.ss" "eopl") 2 | 3 | ;; input language for the CPS converter. 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 | 26 | (expression 27 | ("-" "(" expression "," expression ")") 28 | diff-exp) 29 | 30 | (expression 31 | ("+" "(" (separated-list expression ",") ")") 32 | sum-exp) 33 | 34 | (expression 35 | ("zero?" "(" expression ")") 36 | zero?-exp) 37 | 38 | (expression 39 | ("if" expression "then" expression "else" expression) 40 | if-exp) 41 | 42 | (expression 43 | ("letrec" 44 | (arbno identifier "(" (arbno identifier) ")" 45 | "=" expression) 46 | "in" 47 | expression) 48 | letrec-exp) 49 | 50 | (expression (identifier) var-exp) 51 | 52 | (expression 53 | ("let" identifier "=" expression "in" expression) 54 | let-exp) 55 | 56 | (expression 57 | ("proc" "(" (arbno identifier) ")" expression) 58 | proc-exp) 59 | 60 | (expression 61 | ("(" expression (arbno expression) ")") 62 | call-exp) 63 | 64 | )) 65 | 66 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 67 | 68 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 69 | 70 | (define show-the-datatypes 71 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 72 | 73 | (define scan&parse 74 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 75 | 76 | (define just-scan 77 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 78 | 79 | ) 80 | -------------------------------------------------------------------------------- /chapter6/cps-lang/cps-out-lang.scm: -------------------------------------------------------------------------------- 1 | (module cps-out-lang (lib "eopl.ss" "eopl") 2 | 3 | ;; output language from the cps converter 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 8 | 9 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 10 | 11 | (define cps-out-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 cps-out-grammar 22 | 23 | '((cps-out-program (tfexp) cps-a-program) 24 | 25 | (simple-expression (number) cps-const-exp) 26 | 27 | (simple-expression (identifier) cps-var-exp) 28 | 29 | (simple-expression 30 | ("-" "(" simple-expression "," simple-expression ")") 31 | cps-diff-exp) 32 | 33 | (simple-expression 34 | ("zero?" "(" simple-expression ")") 35 | cps-zero?-exp) 36 | 37 | (simple-expression 38 | ("+" "(" (separated-list simple-expression ",") ")") 39 | cps-sum-exp) 40 | 41 | (simple-expression 42 | ("proc" "(" (arbno identifier) ")" tfexp) 43 | cps-proc-exp) 44 | 45 | (tfexp 46 | (simple-expression) 47 | simple-exp->exp) 48 | 49 | (tfexp 50 | ("let" identifier "=" simple-expression "in" tfexp) 51 | cps-let-exp) 52 | 53 | (tfexp 54 | ("letrec" 55 | (arbno identifier "(" (arbno identifier) ")" 56 | "=" tfexp) 57 | "in" 58 | tfexp) 59 | cps-letrec-exp) 60 | 61 | (tfexp 62 | ("if" simple-expression "then" tfexp "else" tfexp) 63 | cps-if-exp) 64 | 65 | (tfexp 66 | ("(" simple-expression (arbno simple-expression) ")") 67 | cps-call-exp) 68 | 69 | )) 70 | 71 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 72 | 73 | (sllgen:make-define-datatypes cps-out-lexical-spec cps-out-grammar) 74 | 75 | (define cps-show-the-datatypes 76 | (lambda () 77 | (sllgen:list-define-datatypes cps-out-lexical-spec cps-out-grammar))) 78 | 79 | (define cps-out-scan&parse 80 | (sllgen:make-string-parser cps-out-lexical-spec cps-out-grammar)) 81 | 82 | (define cps-out-just-scan 83 | (sllgen:make-string-scanner cps-out-lexical-spec cps-out-grammar)) 84 | 85 | ;;;;;;;;;;;;;;;; a primitive pretty-printer ;;;;;;;;;;;;;;;; 86 | 87 | ;; exercise: Write a pretty-printer for programs in CPS-OUT. 88 | 89 | ;; (define cps-program->string 90 | ;; (lambda (pgm) 91 | ;; (cases cps-out-program pgm 92 | ;; (cps-a-program (exp1) (tfexp->string exp1 0))))) 93 | 94 | ) 95 | -------------------------------------------------------------------------------- /chapter6/cps-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 | ;;; interface for book test ;;; 7 | (provide test-all) 8 | (define (test-all) 9 | (run-all)) 10 | 11 | (require "drscheme-init.scm") 12 | (require "data-structures.scm") ; for expval constructors 13 | (require "cps-in-lang.scm") ; for scan&parse 14 | (require "cps.scm") ; for cps transformer 15 | (require "interp.scm") ; for value-of-program 16 | (require "tests.scm") ; for test-list 17 | 18 | (require "cps-out-lang.scm") ; for cps-program->string 19 | 20 | (provide (all-defined-out)) 21 | (provide (all-from-out "interp.scm")) 22 | 23 | (define instrument-cps (make-parameter #f)) 24 | 25 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 26 | 27 | ;; run : String -> ExpVal 28 | 29 | (define run 30 | (lambda (string) 31 | (let ((cpsed-pgm 32 | (cps-of-program (scan&parse string)))) 33 | (when (instrument-cps) (pretty-print cpsed-pgm)) 34 | (value-of-program cpsed-pgm)))) 35 | 36 | (define compile 37 | (lambda (string) 38 | (cps-of-program (scan&parse string)))) 39 | 40 | 41 | ;; run-all : () -> Unspecified 42 | 43 | ;; runs all the tests in test-list, comparing the results with 44 | ;; equal-answer? 45 | 46 | (define run-all 47 | (lambda () 48 | (run-tests! run equal-answer? test-list))) 49 | 50 | (define equal-answer? 51 | (lambda (ans correct-ans) 52 | (equal? ans (sloppy->expval correct-ans)))) 53 | 54 | (define sloppy->expval 55 | (lambda (sloppy-val) 56 | (cond 57 | ((number? sloppy-val) (num-val sloppy-val)) 58 | ((boolean? sloppy-val) (bool-val sloppy-val)) 59 | (else 60 | (eopl:error 'sloppy->expval 61 | "Can't convert sloppy value to expval: ~s" 62 | sloppy-val))))) 63 | 64 | ;; run-one : Symbol -> ExpVal 65 | 66 | ;; (run-one sym) runs the test whose name is sym 67 | 68 | (define run-one 69 | (lambda (test-name) 70 | (let ((the-test (assoc test-name test-list))) 71 | (cond 72 | ((assoc test-name test-list) 73 | => (lambda (test) 74 | (run (cadr test)))) 75 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 76 | 77 | ;; (stop-after-first-error #t) 78 | ;; (run-all) 79 | 80 | ) 81 | 82 | 83 | 84 | 85 | -------------------------------------------------------------------------------- /chapter6/cps-side-effects-lang/cps-in-lang.scm: -------------------------------------------------------------------------------- 1 | (module cps-in-lang (lib "eopl.ss" "eopl") 2 | 3 | ;; input language for the CPS converter, based on EXPLICIT-REFS 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 | 26 | (expression 27 | ("-" "(" expression "," expression ")") 28 | diff-exp) 29 | 30 | (expression 31 | ("+" "(" (separated-list expression ",") ")") 32 | sum-exp) 33 | 34 | (expression 35 | ("zero?" "(" expression ")") 36 | zero?-exp) 37 | 38 | (expression 39 | ("if" expression "then" expression "else" expression) 40 | if-exp) 41 | 42 | (expression 43 | ("letrec" 44 | (arbno identifier "(" (arbno identifier) ")" 45 | "=" expression) 46 | "in" 47 | expression) 48 | letrec-exp) 49 | 50 | (expression (identifier) var-exp) 51 | 52 | (expression 53 | ("let" identifier "=" expression "in" expression) 54 | let-exp) 55 | 56 | (expression 57 | ("proc" "(" (arbno identifier) ")" expression) 58 | proc-exp) 59 | 60 | (expression 61 | ("(" expression (arbno expression) ")") 62 | call-exp) 63 | 64 | (expression 65 | ("print" "(" expression ")") 66 | print-exp) 67 | 68 | (expression 69 | ("newref" "(" expression ")") 70 | newref-exp) 71 | 72 | (expression 73 | ("deref" "(" expression ")") 74 | deref-exp) 75 | 76 | (expression 77 | ("setref" "(" expression "," expression ")") 78 | setref-exp) 79 | 80 | )) 81 | 82 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 83 | 84 | (sllgen:make-define-datatypes the-lexical-spec the-grammar) 85 | 86 | (define show-the-datatypes 87 | (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar))) 88 | 89 | (define scan&parse 90 | (sllgen:make-string-parser the-lexical-spec the-grammar)) 91 | 92 | (define just-scan 93 | (sllgen:make-string-scanner the-lexical-spec the-grammar)) 94 | 95 | ) 96 | -------------------------------------------------------------------------------- /chapter6/cps-side-effects-lang/cps-out-lang.scm: -------------------------------------------------------------------------------- 1 | (module cps-out-lang (lib "eopl.ss" "eopl") 2 | 3 | ;; output language from the cps converter, including explicit references 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 8 | 9 | ;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;; 10 | 11 | (define cps-out-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 cps-out-grammar 22 | '((cps-out-program (tfexp) cps-a-program) 23 | 24 | (simple-expression (number) cps-const-exp) 25 | 26 | (simple-expression (identifier) cps-var-exp) 27 | 28 | (simple-expression 29 | ("-" "(" simple-expression "," simple-expression ")") 30 | cps-diff-exp) 31 | 32 | (simple-expression 33 | ("zero?" "(" simple-expression ")") 34 | cps-zero?-exp) 35 | 36 | (simple-expression 37 | ("+" "(" (separated-list simple-expression ",") ")") 38 | cps-sum-exp) 39 | 40 | (simple-expression 41 | ("proc" "(" (arbno identifier) ")" tfexp) 42 | cps-proc-exp) 43 | 44 | (tfexp 45 | (simple-expression) 46 | simple-exp->exp) 47 | 48 | (tfexp 49 | ("let" identifier "=" simple-expression "in" tfexp) 50 | cps-let-exp) 51 | 52 | (tfexp 53 | ("letrec" 54 | (arbno identifier "(" (arbno identifier) ")" 55 | "=" tfexp) 56 | "in" 57 | tfexp) 58 | cps-letrec-exp) 59 | 60 | (tfexp 61 | ("if" simple-expression "then" tfexp "else" tfexp) 62 | cps-if-exp) 63 | 64 | (tfexp 65 | ("(" simple-expression (arbno simple-expression) ")") 66 | cps-call-exp) 67 | 68 | (tfexp 69 | ("printk" "(" simple-expression ")" ";" tfexp) 70 | cps-printk-exp) 71 | 72 | (tfexp 73 | ("newrefk" "(" simple-expression "," simple-expression ")") 74 | cps-newrefk-exp) 75 | 76 | (tfexp 77 | ("derefk" "(" simple-expression "," simple-expression ")") 78 | cps-derefk-exp) 79 | 80 | (tfexp 81 | ("setrefk" 82 | "(" simple-expression "," simple-expression ")" ";" 83 | tfexp ) 84 | cps-setrefk-exp) 85 | 86 | )) 87 | 88 | ;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;; 89 | 90 | (sllgen:make-define-datatypes cps-out-lexical-spec cps-out-grammar) 91 | 92 | (define cps-out-show-the-datatypes 93 | (lambda () (sllgen:list-define-datatypes cps-out-lexical-spec cps-out-grammar))) 94 | 95 | (define cps-out-scan&parse 96 | (sllgen:make-string-parser cps-out-lexical-spec cps-out-grammar)) 97 | 98 | (define cps-just-scan 99 | (sllgen:make-string-scanner cps-out-lexical-spec cps-out-grammar)) 100 | 101 | ) 102 | -------------------------------------------------------------------------------- /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-out)) ; 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 | ) 65 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter7/checked/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | 5 | (require "lang.scm") 6 | (require "data-structures.scm") 7 | (require "environments.scm") 8 | 9 | (provide value-of-program value-of) 10 | 11 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 12 | 13 | ;; value-of-program : Program -> Expval 14 | (define value-of-program 15 | (lambda (pgm) 16 | (cases program pgm 17 | (a-program (body) 18 | (value-of body (init-env)))))) 19 | 20 | 21 | ;; value-of : Exp * Env -> ExpVal 22 | (define value-of 23 | (lambda (exp env) 24 | (cases expression exp 25 | 26 | (const-exp (num) (num-val num)) 27 | 28 | (var-exp (var) (apply-env env var)) 29 | 30 | (diff-exp (exp1 exp2) 31 | (let ((val1 32 | (expval->num 33 | (value-of exp1 env))) 34 | (val2 35 | (expval->num 36 | (value-of exp2 env)))) 37 | (num-val 38 | (- val1 val2)))) 39 | 40 | (zero?-exp (exp1) 41 | (let ((val1 (expval->num (value-of exp1 env)))) 42 | (if (zero? val1) 43 | (bool-val #t) 44 | (bool-val #f)))) 45 | 46 | (if-exp (exp0 exp1 exp2) 47 | (if (expval->bool (value-of exp0 env)) 48 | (value-of exp1 env) 49 | (value-of exp2 env))) 50 | 51 | (let-exp (var exp1 body) 52 | (let ((val (value-of exp1 env))) 53 | (value-of body 54 | (extend-env var val env)))) 55 | 56 | (proc-exp (bvar ty body) 57 | (proc-val 58 | (procedure bvar body env))) 59 | 60 | (call-exp (rator rand) 61 | (let ((proc (expval->proc (value-of rator env))) 62 | (arg (value-of rand env))) 63 | (apply-procedure proc arg))) 64 | 65 | (letrec-exp (ty1 p-name b-var ty2 p-body letrec-body) 66 | (value-of letrec-body 67 | (extend-env-rec p-name b-var p-body env))) 68 | 69 | ))) 70 | 71 | ;; apply-procedure : Proc * ExpVal -> ExpVal 72 | (define apply-procedure 73 | (lambda (proc1 arg) 74 | (cases proc proc1 75 | (procedure (var body saved-env) 76 | (value-of body (extend-env var arg saved-env)))))) 77 | 78 | ) 79 | 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /chapter7/checked/lang.scm: -------------------------------------------------------------------------------- 1 | (module lang (lib "eopl.ss" "eopl") 2 | 3 | ;; grammar for the CHECKED language 4 | 5 | (require "drscheme-init.scm") 6 | 7 | (provide (all-defined-out)) 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 ":" type ")" expression) 45 | proc-exp) 46 | 47 | (expression 48 | ("(" expression expression ")") 49 | call-exp) 50 | 51 | (expression 52 | ("letrec" 53 | type identifier "(" identifier ":" type ")" "=" expression 54 | "in" expression) 55 | letrec-exp) 56 | 57 | (type 58 | ("int") 59 | int-type) 60 | 61 | (type 62 | ("bool") 63 | bool-type) 64 | 65 | (type 66 | ("(" type "->" type ")") 67 | proc-type) 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 | 84 | ;;;;;;;;;;;;;;;; type-to-external-form ;;;;;;;;;;;;;;;; 85 | 86 | ;; type-to-external-form : Type -> List 87 | ;; Page: 243 88 | (define type-to-external-form 89 | (lambda (ty) 90 | (cases type ty 91 | (int-type () 'int) 92 | (bool-type () 'bool) 93 | (proc-type (arg-type result-type) 94 | (list 95 | (type-to-external-form arg-type) 96 | '-> 97 | (type-to-external-form result-type)))))) 98 | 99 | ) 100 | -------------------------------------------------------------------------------- /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-out)) ; 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 | ) 65 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter7/inferred/equal-up-to-gensyms.scm: -------------------------------------------------------------------------------- 1 | (module equal-up-to-gensyms (lib "eopl.ss" "eopl") 2 | 3 | (provide equal-types?) 4 | 5 | (define equal-types? 6 | (lambda (ty1 ty2) 7 | (equal-up-to-gensyms? ty1 ty2))) 8 | 9 | ;; S-exp = Sym | Listof(S-exp) 10 | ;; A-list = Listof(Pair(TvarTypeSym, TvarTypesym)) 11 | ;; a tvar-type-sym is a symbol ending with a digit. 12 | 13 | ;; equal-up-to-gensyms? : S-exp * S-exp -> Bool 14 | ;; Page: 271 15 | (define equal-up-to-gensyms? 16 | (lambda (sexp1 sexp2) 17 | (equal? 18 | (apply-subst-to-sexp (canonical-subst sexp1) sexp1) 19 | (apply-subst-to-sexp (canonical-subst sexp2) sexp2)))) 20 | 21 | ;; canonicalize : S-exp -> A-list 22 | ;; usage: replaces all tvar-syms with tvar1, tvar2, etc. 23 | ;; Page: 271 24 | (define canonical-subst 25 | (lambda (sexp) 26 | ;; loop : sexp * alist -> alist 27 | (let loop ((sexp sexp) (table '())) 28 | (cond 29 | ((null? sexp) table) 30 | ((tvar-type-sym? sexp) 31 | (cond 32 | ((assq sexp table) ; sexp is already bound, no more to 33 | ; do 34 | table) 35 | (else 36 | (cons 37 | ;; the length of the table serves as a counter! 38 | (cons sexp (ctr->ty (length table))) 39 | table)))) 40 | ((pair? sexp) 41 | (loop (cdr sexp) 42 | (loop (car sexp) table))) 43 | (else table))))) 44 | 45 | ;; tvar-type-sym? : Sym -> Bool 46 | ;; Page: 272 47 | (define tvar-type-sym? 48 | (lambda (sym) 49 | (and (symbol? sym) 50 | (char-numeric? (car (reverse (symbol->list sym))))))) 51 | 52 | ;; symbol->list : Sym -> List 53 | ;; Page: 272 54 | (define symbol->list 55 | (lambda (x) (string->list (symbol->string x)))) 56 | 57 | ;; apply-subst-to-sexp : A-list * S-exp -> S-exp 58 | ;; Page: 272 59 | (define apply-subst-to-sexp 60 | (lambda (subst sexp) 61 | (cond 62 | ((null? sexp) sexp) 63 | ((tvar-type-sym? sexp) 64 | (cdr (assq sexp subst))) 65 | ((pair? sexp) 66 | (cons 67 | (apply-subst-to-sexp subst (car sexp)) 68 | (apply-subst-to-sexp subst (cdr sexp)))) 69 | (else sexp)))) 70 | 71 | ;; ctr->ty : N -> Sym 72 | ;; Page: 272 73 | (define ctr->ty 74 | (lambda (n) 75 | (string->symbol 76 | (string-append 77 | "tvar" 78 | (number->string n))))) 79 | 80 | 81 | ) -------------------------------------------------------------------------------- /chapter7/inferred/interp.scm: -------------------------------------------------------------------------------- 1 | (module interp (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | 5 | (require "lang.scm") 6 | (require "data-structures.scm") 7 | (require "environments.scm") 8 | 9 | (provide value-of-program value-of) 10 | 11 | ;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;; 12 | 13 | ;; value-of-program : Program -> ExpVal 14 | (define value-of-program 15 | (lambda (pgm) 16 | (cases program pgm 17 | (a-program (body) 18 | (value-of body (init-env)))))) 19 | 20 | ;; value-of : Exp * Env -> ExpVal 21 | (define value-of 22 | (lambda (exp env) 23 | (cases expression exp 24 | 25 | (const-exp (num) (num-val num)) 26 | 27 | (var-exp (var) (apply-env env var)) 28 | 29 | (diff-exp (exp1 exp2) 30 | (let ((val1 31 | (expval->num 32 | (value-of exp1 env))) 33 | (val2 34 | (expval->num 35 | (value-of exp2 env)))) 36 | (num-val 37 | (- val1 val2)))) 38 | 39 | (zero?-exp (exp1) 40 | (let ((val1 (expval->num (value-of exp1 env)))) 41 | (if (zero? val1) 42 | (bool-val #t) 43 | (bool-val #f)))) 44 | 45 | (if-exp (exp0 exp1 exp2) 46 | (if (expval->bool (value-of exp0 env)) 47 | (value-of exp1 env) 48 | (value-of exp2 env))) 49 | 50 | (let-exp (var exp1 body) 51 | (let ((val (value-of exp1 env))) 52 | (value-of body 53 | (extend-env var val env)))) 54 | 55 | (proc-exp (bvar ty body) 56 | (proc-val 57 | (procedure bvar body env))) 58 | 59 | (call-exp (rator rand) 60 | (let ((proc (expval->proc (value-of rator env))) 61 | (arg (value-of rand env))) 62 | (apply-procedure proc arg))) 63 | 64 | (letrec-exp (ty1 p-name b-var ty2 p-body letrec-body) 65 | (value-of letrec-body 66 | (extend-env-rec p-name b-var p-body env))) 67 | 68 | ))) 69 | 70 | ;; apply-procedure : Proc * ExpVal -> ExpVal 71 | (define apply-procedure 72 | (lambda (proc1 arg) 73 | (cases proc proc1 74 | (procedure (var body saved-env) 75 | (value-of body (extend-env var arg saved-env)))))) 76 | 77 | ) 78 | 79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /chapter7/inferred/unifier.scm: -------------------------------------------------------------------------------- 1 | (module unifier (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "lang.scm") 5 | (require "data-structures.scm") 6 | (require "substitutions.scm") 7 | 8 | ;; this provides a new view of substitutions, in which unifier 9 | ;; replaces extend-env as a constructor. 10 | (provide unifier substitution? empty-subst apply-subst-to-type) 11 | 12 | ;; we'll maintain the invariant that no variable bound in the 13 | ;; substitution occurs in any of the right-hand sides of the 14 | ;; substitution. 15 | 16 | 17 | ;;;;;;;;;;;;;;;; the unifier ;;;;;;;;;;;;;;;; 18 | 19 | ;; unifier : Type * Type * Subst * Exp -> Subst OR Fails 20 | ;; Page: 264 21 | (define unifier 22 | (lambda (ty1 ty2 subst exp) 23 | (let ((ty1 (apply-subst-to-type ty1 subst)) 24 | (ty2 (apply-subst-to-type ty2 subst))) 25 | (cond 26 | ((equal? ty1 ty2) subst) 27 | ((tvar-type? ty1) 28 | (if (no-occurrence? ty1 ty2) 29 | (extend-subst subst ty1 ty2) 30 | (report-no-occurrence-violation ty1 ty2 exp))) 31 | ((tvar-type? ty2) 32 | (if (no-occurrence? ty2 ty1) 33 | (extend-subst subst ty2 ty1) 34 | (report-no-occurrence-violation ty2 ty1 exp))) 35 | ((and (proc-type? ty1) (proc-type? ty2)) 36 | (let ((subst (unifier 37 | (proc-type->arg-type ty1) 38 | (proc-type->arg-type ty2) 39 | subst exp))) 40 | (let ((subst (unifier 41 | (proc-type->result-type ty1) 42 | (proc-type->result-type ty2) 43 | subst exp))) 44 | subst))) 45 | (else (report-unification-failure ty1 ty2 exp)))))) 46 | 47 | (define report-unification-failure 48 | (lambda (ty1 ty2 exp) 49 | (eopl:error 'unification-failure 50 | "Type mismatch: ~s doesn't match ~s in ~s~%" 51 | (type-to-external-form ty1) 52 | (type-to-external-form ty2) 53 | exp))) 54 | 55 | (define report-no-occurrence-violation 56 | (lambda (ty1 ty2 exp) 57 | (eopl:error 'check-no-occurence! 58 | "Can't unify: type variable ~s occurs in type ~s in expression ~s~%" 59 | (type-to-external-form ty1) 60 | (type-to-external-form ty2) 61 | exp))) 62 | 63 | ;; no-occurrence? : Tvar * Type -> Bool 64 | ;; usage: Is there an occurrence of tvar in ty? 65 | ;; Page: 265 66 | (define no-occurrence? 67 | (lambda (tvar ty) 68 | (cases type ty 69 | (int-type () #t) 70 | (bool-type () #t) 71 | (proc-type (arg-type result-type) 72 | (and 73 | (no-occurrence? tvar arg-type) 74 | (no-occurrence? tvar result-type))) 75 | (tvar-type (serial-number) (not (equal? tvar ty)))))) 76 | 77 | ) -------------------------------------------------------------------------------- /chapter8/abstract-types-lang/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined-out)) ; 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 | ;;;;;;;;;;;;;;;; module values ;;;;;;;;;;;;;;;; 53 | 54 | ;; Page: 282, 319 55 | (define-datatype typed-module typed-module? 56 | (simple-module 57 | (bindings environment?)) 58 | (proc-module 59 | (bvar symbol?) 60 | (body module-body?) 61 | (saved-env environment?)) 62 | ) 63 | 64 | ;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;; 65 | 66 | ;; Page: 282 67 | (define-datatype environment environment? 68 | (empty-env) 69 | (extend-env 70 | (bvar symbol?) 71 | (bval expval?) 72 | (saved-env environment?)) 73 | (extend-env-recursively 74 | (id symbol?) 75 | (bvar symbol?) 76 | (body expression?) 77 | (saved-env environment?)) 78 | (extend-env-with-module 79 | (m-name symbol?) 80 | (m-val typed-module?) 81 | (saved-env environment?) 82 | )) 83 | 84 | ) 85 | -------------------------------------------------------------------------------- /chapter8/abstract-types-lang/renaming.scm: -------------------------------------------------------------------------------- 1 | (module renaming (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") 4 | 5 | (provide rename-in-iface fresh-module-name) 6 | 7 | (define rename-in-iface 8 | (lambda (m-type old new) 9 | (cases interface m-type 10 | (simple-iface (decls) 11 | (simple-iface 12 | (rename-in-decls decls old new))) ))) 13 | 14 | ;; this isn't a map because we have let* scoping in a list of declarations 15 | (define rename-in-decls 16 | (lambda (decls old new) 17 | (if (null? decls) '() 18 | (let ((decl (car decls)) 19 | (decls (cdr decls))) 20 | (cases declaration decl 21 | (val-decl (name ty) 22 | (cons 23 | (val-decl name (rename-in-type ty old new)) 24 | (rename-in-decls decls old new))) 25 | (opaque-type-decl (name) 26 | (cons 27 | (opaque-type-decl name) 28 | (if (eqv? name old) 29 | decls 30 | (rename-in-decls decls old new)))) 31 | (transparent-type-decl (name ty) 32 | (cons 33 | (transparent-type-decl 34 | name 35 | (rename-in-type ty old new)) 36 | (if (eqv? name old) 37 | decls 38 | (rename-in-decls decls old new)))) 39 | ))))) 40 | 41 | (define rename-in-type 42 | (lambda (ty old new) 43 | (let recur ((ty ty)) 44 | (cases type ty 45 | (named-type (id) 46 | (named-type (rename-name id old new))) 47 | (qualified-type (m-name name) 48 | (qualified-type 49 | (rename-name m-name old new) 50 | name)) 51 | (proc-type (t1 t2) 52 | (proc-type (recur t1) (recur t2))) 53 | (else ty) ; this covers int, bool, and unknown. 54 | )))) 55 | 56 | (define rename-name 57 | (lambda (name old new) 58 | (if (eqv? name old) new name))) 59 | 60 | (define fresh-module-name 61 | (let ((sn 0)) 62 | (lambda (module-name) 63 | (set! sn (+ sn 1)) 64 | (string->symbol 65 | (string-append 66 | (symbol->string module-name) 67 | "%" ; this can't appear in an input identifier 68 | (number->string sn)))))) 69 | 70 | ) 71 | 72 | -------------------------------------------------------------------------------- /chapter8/full-system/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined-out)) ; 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 | ;;;;;;;;;;;;;;;; module values ;;;;;;;;;;;;;;;; 53 | 54 | ;; Page: 282, 319 55 | (define-datatype typed-module typed-module? 56 | (simple-module 57 | (bindings environment?)) 58 | (proc-module 59 | (bvar symbol?) 60 | (body module-body?) 61 | (saved-env environment?)) 62 | ) 63 | 64 | ;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;; 65 | 66 | ;; Page: 282 67 | (define-datatype environment environment? 68 | (empty-env) 69 | (extend-env 70 | (bvar symbol?) 71 | (bval expval?) 72 | (saved-env environment?)) 73 | (extend-env-recursively 74 | (id symbol?) 75 | (bvar symbol?) 76 | (body expression?) 77 | (saved-env environment?)) 78 | (extend-env-with-module 79 | (m-name symbol?) 80 | (m-val typed-module?) 81 | (saved-env environment?) 82 | )) 83 | 84 | ) 85 | -------------------------------------------------------------------------------- /chapter8/full-system/renaming.scm: -------------------------------------------------------------------------------- 1 | (module renaming (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") 4 | 5 | (provide rename-in-iface fresh-module-name) 6 | 7 | (define rename-in-iface 8 | (lambda (m-type old new) 9 | (cases interface m-type 10 | (simple-iface (decls) 11 | (simple-iface 12 | (rename-in-decls decls old new))) 13 | (proc-iface (param-name param-type result-type) 14 | (proc-iface 15 | param-name 16 | (rename-in-iface param-type old new) 17 | (if (eqv? param-name old) 18 | result-type 19 | (rename-in-iface result-type old new)))) 20 | (else (eopl:error 'rename-in-iface 21 | "unknown module type ~s" 22 | m-type)) 23 | ))) 24 | 25 | ;; this isn't a map because we have let* scoping in a list of declarations 26 | (define rename-in-decls 27 | (lambda (decls old new) 28 | (if (null? decls) '() 29 | (let ((decl (car decls)) 30 | (decls (cdr decls))) 31 | (cases declaration decl 32 | (val-decl (name ty) 33 | (cons 34 | (val-decl name (rename-in-type ty old new)) 35 | (rename-in-decls decls old new))) 36 | (opaque-type-decl (name) 37 | (cons 38 | (opaque-type-decl name) 39 | (if (eqv? name old) 40 | decls 41 | (rename-in-decls decls old new)))) 42 | (transparent-type-decl (name ty) 43 | (cons 44 | (transparent-type-decl 45 | name 46 | (rename-in-type ty old new)) 47 | (if (eqv? name old) 48 | decls 49 | (rename-in-decls decls old new)))) 50 | ))))) 51 | 52 | (define rename-in-type 53 | (lambda (ty old new) 54 | (let recur ((ty ty)) 55 | (cases type ty 56 | (named-type (id) 57 | (named-type (rename-name id old new))) 58 | (qualified-type (m-name name) 59 | (qualified-type 60 | (rename-name m-name old new) 61 | name)) 62 | (proc-type (t1 t2) 63 | (proc-type (recur t1) (recur t2))) 64 | (else ty) ; this covers int, bool, and unknown. 65 | )))) 66 | 67 | (define rename-name 68 | (lambda (name old new) 69 | (if (eqv? name old) new name))) 70 | 71 | (define fresh-module-name 72 | (let ((sn 0)) 73 | (lambda (module-name) 74 | (set! sn (+ sn 1)) 75 | (string->symbol 76 | (string-append 77 | (symbol->string module-name) 78 | "%" ; this can't appear in an input identifier 79 | (number->string sn)))))) 80 | 81 | ) 82 | 83 | -------------------------------------------------------------------------------- /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 '**)))) -------------------------------------------------------------------------------- /chapter8/simplemodules/check-modules.scm: -------------------------------------------------------------------------------- 1 | (module check-modules (lib "eopl.ss" "eopl") 2 | 3 | (require "drscheme-init.scm") 4 | (require "lang.scm") 5 | (require "static-data-structures.scm") 6 | (require "checker.scm") 7 | (require "subtyping.scm") 8 | 9 | (provide type-of-program) 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | ;; type-of-program : Program -> Type 14 | ;; Page: 286 15 | (define type-of-program 16 | (lambda (pgm) 17 | (cases program pgm 18 | (a-program (module-defs body) 19 | (type-of body 20 | (add-module-defns-to-tenv module-defs (empty-tenv))))))) 21 | 22 | ;; add-module-defns-to-tenv : Listof(ModuleDefn) * Tenv -> Tenv 23 | ;; Page: 286 24 | (define add-module-defns-to-tenv 25 | (lambda (defns tenv) 26 | (if (null? defns) 27 | tenv 28 | (cases module-definition (car defns) 29 | (a-module-definition (m-name expected-iface m-body) 30 | (let ((actual-iface (interface-of m-body tenv))) 31 | (if (<:-iface actual-iface expected-iface tenv) 32 | (let ((new-tenv 33 | (extend-tenv-with-module 34 | m-name 35 | expected-iface 36 | tenv))) 37 | (add-module-defns-to-tenv 38 | (cdr defns) new-tenv)) 39 | (report-module-doesnt-satisfy-iface 40 | m-name expected-iface actual-iface)))))))) 41 | 42 | ;; interface-of : ModuleBody * Tenv -> Iface 43 | ;; Page: 288 44 | (define interface-of 45 | (lambda (m-body tenv) 46 | (cases module-body m-body 47 | (defns-module-body (defns) 48 | (simple-iface 49 | (defns-to-decls defns tenv))) ))) 50 | 51 | ;; defns-to-decls : Listof(Defn) * Tenv -> Listof(Decl) 52 | ;; Page: 288 53 | ;; 54 | ;; Convert defns to a set of declarations for just the names defined 55 | ;; in defns. Do this in the context of tenv. The tenv is extended 56 | ;; at every step, so we get the correct let* scoping 57 | ;; 58 | (define defns-to-decls 59 | (lambda (defns tenv) 60 | (if (null? defns) 61 | '() 62 | (cases definition (car defns) 63 | (val-defn (var-name exp) 64 | (let ((ty (type-of exp tenv))) 65 | (let ((new-env (extend-tenv var-name ty tenv))) 66 | (cons 67 | (val-decl var-name ty) 68 | (defns-to-decls (cdr defns) new-env))))))))) 69 | 70 | (define report-module-doesnt-satisfy-iface 71 | (lambda (m-name expected-type actual-type) 72 | (pretty-print 73 | (list 'error-in-defn-of-module: m-name 74 | 'expected-type: expected-type 75 | 'actual-type: actual-type)) 76 | (eopl:error 'type-of-module-defn))) 77 | 78 | ) -------------------------------------------------------------------------------- /chapter8/simplemodules/data-structures.scm: -------------------------------------------------------------------------------- 1 | (module data-structures (lib "eopl.ss" "eopl") 2 | 3 | (require "lang.scm") ; for expression? 4 | 5 | (provide (all-defined-out)) ; 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 | ;;;;;;;;;;;;;;;; module values ;;;;;;;;;;;;;;;; 53 | 54 | ;; Page: 282, 319 55 | (define-datatype typed-module typed-module? 56 | (simple-module 57 | (bindings environment?)) 58 | (proc-module 59 | (bvar symbol?) 60 | (body module-body?) 61 | (saved-env environment?)) 62 | ) 63 | 64 | ;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;; 65 | 66 | ;; Page: 282 67 | (define-datatype environment environment? 68 | (empty-env) 69 | (extend-env 70 | (bvar symbol?) 71 | (bval expval?) 72 | (saved-env environment?)) 73 | (extend-env-recursively 74 | (id symbol?) 75 | (bvar symbol?) 76 | (body expression?) 77 | (saved-env environment?)) 78 | (extend-env-with-module 79 | (m-name symbol?) 80 | (m-val typed-module?) 81 | (saved-env environment?) 82 | )) 83 | 84 | ) 85 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | ) -------------------------------------------------------------------------------- /chapter8/simplemodules/tests-book.scm: -------------------------------------------------------------------------------- 1 | (module tests-book mzscheme 2 | 3 | (provide tests-for-run tests-for-check tests-for-parse) 4 | ;;;;;;;;;;;;;;;; tests ;;;;;;;;;;;;;;;; 5 | 6 | (define the-test-suite 7 | 8 | '( 9 | 10 | (modules-dans-simplest " 11 | module m1 12 | interface 13 | [a : int 14 | b : int] 15 | body 16 | [a = 33 17 | c = -(a,1) 18 | b = -(c,a)] 19 | 20 | let a = 10 21 | in -(-(from m1 take a, from m1 take b), 22 | a)" 23 | int 24) 24 | 25 | 26 | (example-8.2 " 27 | module m1 28 | interface 29 | [u : bool] 30 | body 31 | [u = 33] 32 | 33 | 44" 34 | error 44) 35 | 36 | (example-8.3 " 37 | module m1 38 | interface 39 | [u : int 40 | v : int] 41 | body 42 | [u = 33] 43 | 44 | 44" 45 | error) 46 | 47 | (example-8.4 " 48 | module m1 49 | interface 50 | [u : int 51 | v : int] 52 | body 53 | [v = 33 54 | u = 44] 55 | 56 | from m1 take u" 57 | error) 58 | 59 | (example-8.5a " 60 | module m1 61 | interface 62 | [u : int] 63 | body 64 | [u = 44] 65 | 66 | module m2 67 | interface 68 | [v : int] 69 | body 70 | [v = -(from m1 take u,11)] 71 | 72 | -(from m1 take u, from m2 take v)" 73 | int) 74 | 75 | (example-8.5b " 76 | module m2 77 | interface [v : int] 78 | body 79 | [v = -(from m1 take u,11)] 80 | 81 | module m1 82 | interface [u : int] 83 | body [u = 44] 84 | 85 | -(from m1 take u, from m2 take v)" 86 | error) 87 | 88 | )) 89 | 90 | (define tests-for-run 91 | (let loop ((lst the-test-suite)) 92 | (cond 93 | ((null? lst) '()) 94 | ((= (length (car lst)) 4) 95 | ;; (printf "creating item: ~s~%" (caar lst)) 96 | (cons 97 | (list 98 | (list-ref (car lst) 0) 99 | (list-ref (car lst) 1) 100 | (list-ref (car lst) 3)) 101 | (loop (cdr lst)))) 102 | (else (loop (cdr lst)))))) 103 | 104 | ;; ok to have extra members in a test-item. 105 | (define tests-for-check the-test-suite) 106 | 107 | (define tests-for-parse the-test-suite) 108 | 109 | ) 110 | 111 | -------------------------------------------------------------------------------- /chapter9/classes/environments.scm: -------------------------------------------------------------------------------- 1 | (module environments (lib "eopl.ss" "eopl") 2 | 3 | (require "data-structures.scm") 4 | (require "store.scm") 5 | 6 | (provide init-env empty-env extend-env apply-env env->list) 7 | 8 | ;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;; 9 | 10 | ;; init-env : () -> environment 11 | 12 | ;; (init-env) builds an environment in which i is bound to the 13 | ;; expressed value 1, v is bound to the expressed value 5, and x is 14 | ;; bound to the expressed value 10. 15 | 16 | (define init-env 17 | (lambda () 18 | (extend-env1 19 | 'i (newref (num-val 1)) 20 | (extend-env1 21 | 'v (newref (num-val 5)) 22 | (extend-env1 23 | 'x (newref (num-val 10)) 24 | (empty-env)))))) 25 | 26 | (define extend-env1 27 | (lambda (id val env) 28 | (extend-env (list id) (list val) env))) 29 | 30 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 31 | 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 (bvars bvals saved-env) 38 | (cond 39 | ((location search-sym bvars) 40 | => (lambda (n) 41 | (list-ref bvals n))) 42 | (else 43 | (apply-env saved-env search-sym)))) 44 | (extend-env-rec** (p-names b-varss p-bodies saved-env) 45 | (cond 46 | ((location search-sym p-names) 47 | => (lambda (n) 48 | (newref 49 | (proc-val 50 | (procedure 51 | (list-ref b-varss n) 52 | (list-ref p-bodies n) 53 | env))))) 54 | (else (apply-env saved-env search-sym)))) 55 | (extend-env-with-self-and-super (self super-name saved-env) 56 | (case search-sym 57 | ((%self) self) 58 | ((%super) super-name) 59 | (else (apply-env saved-env search-sym))))))) 60 | 61 | ;; location : Sym * Listof(Sym) -> Maybe(Int) 62 | ;; (location sym syms) returns the location of sym in syms or #f is 63 | ;; sym is not in syms. We can specify this as follows: 64 | ;; if (memv sym syms) 65 | ;; then (list-ref syms (location sym syms)) = sym 66 | ;; else (location sym syms) = #f 67 | (define location 68 | (lambda (sym syms) 69 | (cond 70 | ((null? syms) #f) 71 | ((eqv? sym (car syms)) 0) 72 | ((location sym (cdr syms)) 73 | => (lambda (n) 74 | (+ n 1))) 75 | (else #f)))) 76 | 77 | ) 78 | -------------------------------------------------------------------------------- /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 | ;;; interface for book test ;;; 15 | (provide test-all) 16 | (define (test-all) 17 | (run-all)) 18 | 19 | ;;;;;;;;;;;;;;;; interface to test harness ;;;;;;;;;;;;;;;; 20 | 21 | ;; run : String -> ExpVal 22 | 23 | (define run 24 | (lambda (string) 25 | (value-of-program (scan&parse string)))) 26 | 27 | ;; run-all : () -> Unspecified 28 | 29 | ;; runs all the tests in test-list, comparing the results with 30 | ;; equal-answer? 31 | 32 | (define run-all 33 | (lambda () 34 | (run-tests! run equal-answer? test-list))) 35 | 36 | (define equal-answer? 37 | (lambda (ans correct-ans) 38 | (equal? ans (sloppy->expval correct-ans)))) 39 | 40 | (define sloppy->expval 41 | (lambda (sloppy-val) 42 | (cond 43 | ((number? sloppy-val) (num-val sloppy-val)) 44 | ((boolean? sloppy-val) (bool-val sloppy-val)) 45 | ((list? sloppy-val) (list-val (map sloppy->expval sloppy-val))) 46 | (else 47 | (eopl:error 'sloppy->expval 48 | "Can't convert sloppy value to expval: ~s" 49 | sloppy-val))))) 50 | 51 | ;; run-one : Sym -> ExpVal 52 | 53 | ;; (run-one sym) runs the test whose name is sym 54 | 55 | (define run-one 56 | (lambda (test-name) 57 | (let ((the-test (assoc test-name test-list))) 58 | (cond 59 | ((assoc test-name test-list) 60 | => (lambda (test) 61 | (run (cadr test)))) 62 | (else (eopl:error 'run-one "no such test: ~s" test-name)))))) 63 | 64 | ;; (run-all) 65 | 66 | ) 67 | 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /chapter9/typed-oo/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 env->list) 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-env1 18 | 'i (newref (num-val 1)) 19 | (extend-env1 20 | 'v (newref (num-val 5)) 21 | (extend-env1 22 | 'x (newref (num-val 10)) 23 | (empty-env)))))) 24 | 25 | (define extend-env1 26 | (lambda (id val env) 27 | (extend-env (list id) (list val) env))) 28 | 29 | ;;;;;;;;;;;;;;;; environment constructors and observers ;;;;;;;;;;;;;;;; 30 | 31 | (define apply-env 32 | (lambda (env search-sym) 33 | (cases environment env 34 | (empty-env () 35 | (eopl:error 'apply-env "No binding for ~s" search-sym)) 36 | (extend-env (bvars bvals saved-env) 37 | (cond 38 | ((location search-sym bvars) 39 | => (lambda (n) 40 | (list-ref bvals n))) 41 | (else 42 | (apply-env saved-env search-sym)))) 43 | (extend-env-rec** (p-names b-varss p-bodies saved-env) 44 | (cond 45 | ((location search-sym p-names) 46 | => (lambda (n) 47 | (newref 48 | (proc-val 49 | (procedure 50 | (list-ref b-varss n) 51 | (list-ref p-bodies n) 52 | env))))) 53 | (else (apply-env saved-env search-sym)))) 54 | (extend-env-with-self-and-super (self super-name saved-env) 55 | (case search-sym 56 | ((%self) self) 57 | ((%super) super-name) 58 | (else (apply-env saved-env search-sym))))))) 59 | 60 | ;; location : Sym * Listof(Sym) -> Maybe(Int) 61 | ;; (location sym syms) returns the location of sym in syms or #f is 62 | ;; sym is not in syms. We can specify this as follows: 63 | ;; if (memv sym syms) 64 | ;; then (list-ref syms (location sym syms)) = sym 65 | ;; else (location sym syms) = #f 66 | (define location 67 | (lambda (sym syms) 68 | (cond 69 | ((null? syms) #f) 70 | ((eqv? sym (car syms)) 0) 71 | ((location sym (cdr syms)) 72 | => (lambda (n) 73 | (+ n 1))) 74 | (else #f)))) 75 | 76 | ) 77 | -------------------------------------------------------------------------------- /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-out)) 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 | ) 57 | --------------------------------------------------------------------------------