├── .io.livecode.ch ├── _site │ └── index.html ├── defaults.json ├── install └── run ├── README ├── README.md ├── black-with-delta.scm ├── black.scm ├── break.blk ├── compare ├── env.scm ├── examples ├── church.scm ├── cnv.scm ├── instr.blk ├── instr2.blk ├── pal.scm ├── stack.scm ├── start.scm ├── taba.blk ├── taba2.blk ├── taba3.blk ├── transcript.scm └── utils.blk ├── init.scm ├── int.scm └── stream.scm /.io.livecode.ch/_site/index.html: -------------------------------------------------------------------------------- 1 | {% extends "base_livecode.html" %} 2 | 3 | {% block title %}The reflective language Black{% endblock %} 4 | 5 | {% block content %} 6 |

Warm up

7 | 8 |

Just like Scheme... at first.

9 |

10 | (+ 2 1) 11 | (define inc (lambda (x) (+ x 1))) 12 | (inc 2) 13 | ((lambda (x) (+ x 1)) 2) 14 | (map inc '(1 2 3)) 15 | (map (lambda (x) (+ x 1)) '(1 2 3)) 16 |

17 | 18 |

Error loads new meta level.

19 |

20 | (incr 2) 21 |

22 |

Notice the prompt change, from 0-7 to 1-0. 23 | The first number is the meta level, i.e. the n in metaⁿ level. The second number is just the iteration counter at this level.

24 | 25 |

Two ways to go back down.

26 | 27 |

(1) call old-cont.

28 |

29 | (old-cont (lambda (x) (+ x 1))) 30 |

31 |

(2) use (base-eval exp env cont).

32 |

39 | 40 |

Notice we needed to quote inc at the meta-level. Why? 41 | Let's jump back to the meta¹ level and see. 42 | We can jump levels normally with exit, no need to fake errors.

43 |

44 | (exit 'hello) 45 | 46 | ;; inc is not defined 47 | inc 48 |

49 | 50 |

Oh, we loaded meta² now! Let's go back to 0:

51 |

52 | (old-cont 1) 53 | (old-cont 'back-to-user-level) 54 |

55 | 56 |

To recap, a variable is local to a level:

57 |

68 | 69 |

Can we access some meta level without pushing away (or popping? which way does it go?) without leaving the level? Yes, with EM.

70 |

81 |

Interesting, we got straight back to 0 from 3, some jumping indeed!

82 | 83 |

The Mystery of Meta-Continuations Revealed

84 | 85 |

Each level in the tower has its own environment and continuation.

86 | 87 |

Bouncing Up and Down

88 | 89 |

First, we redefine evaluation of variable (by mutating the meta 90 | level) so that when the variable name is _dummy we do 91 | something special: we call the continuation first with 1, then 2, then 3.

92 |

100 | 101 |

What happens when we evaluate _dummy?

102 |

103 | _dummy 104 |

105 | 106 |

OK, so it seems that it just jumps out at the first 1? Not so fast:

107 |

113 | 114 |

Being Pushy... Bug or Feature?

115 | 116 |

136 | 137 |

Fun with Towers

143 | 144 |

The loaded code in the examples below is also on Github.

145 | 146 |

Counting Evaluations

147 | 148 |

Learn more about Church Encodings on Wikipedia. See also section 5.2 (Programming in the Lambda-Calculus) of Types and Programming Languages by Pierce.

149 | 150 |

158 | 159 |

There and Back Again

160 | 161 |

There is a cute trick by Danvy et al. 162 | (ICFP, 163 | extended journal version) to construct (cnv xs ys) = (zip xs (reverse ys)) in n recursive calls and no auxiliary data list, where xs and ys are lists of size n.

164 | 165 |

It's fun to think about it, so let's not give it away. Suffice to 166 | say that it's helpful to visualize the stack.

167 |

176 | 177 |

187 | 188 |

Your Turn

189 | 190 |

191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 |

210 | 211 |

Happy Happy Joy Joy!

212 | 213 | {% endblock %} 214 | -------------------------------------------------------------------------------- /.io.livecode.ch/defaults.json: -------------------------------------------------------------------------------- 1 | { 2 | "language" : "scheme" 3 | } 4 | -------------------------------------------------------------------------------- /.io.livecode.ch/install: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | echo OK -------------------------------------------------------------------------------- /.io.livecode.ch/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | echo "(load-option 'format)" >format.scm 5 | cat $2 $1 >out.scm 6 | mechanics-shell --load format.scm --load init.scm macro 75 | (lambda (x env) 76 | (let ((a (cadr x)) 77 | (b (caddr x))) 78 | `(cons ,a (delay ,b)))))) 79 | 80 | (define scheme-apply apply) 81 | (load "env.scm") 82 | (load "black.scm") or (load "black-with-delta.scm") 83 | (black) 84 | 85 | elk: 86 | (define head car) 87 | (define (tail x) (force (cdr x))) 88 | (define-macro (cons-stream a b) 89 | `(cons ,a (delay ,b))) 90 | (autoload 'pp 'pp) 91 | 92 | (define scheme-apply apply) 93 | (load "env.scm") 94 | (load "black.scm") or (load "black-with-delta.scm") 95 | (black) 96 | 97 | It seems that elk does not handle mutual tail recursion correctly. 98 | Thus, stack overflow will eventually occur. 99 | 100 | To quit Black, type an interrupt key. Black has no command to quit 101 | the system. (exit 0) will merely exit the current level. 102 | 103 | The extensions that are not described in the paper are as follows: 104 | 105 | 1. Special forms not described in the paper (cond, let, etc.) are 106 | supported. 107 | 108 | 2. Special forms delay, force, cons-stream, and primitive-EM are 109 | supported, so that the implementation is meta-circular. You can 110 | execute Black on top of Black by typing the followings in Black: 111 | 112 | (define head car) 113 | (define (tail x) (force (cdr x))) 114 | (load "env.scm") 115 | (load "black.scm") or (load "black-with-delta.scm") 116 | (black) 117 | 118 | 3. (if ) without is supported. 119 | 120 | 4. The error "Wrong number of arguments" (for lambda closures) is 121 | supported. 122 | 123 | When errors such as "Unbound variables" and "Not a Function" occur, 124 | the current level is properly terminated, and the control moves to the 125 | upper level. However, some errors cause the Black system to stop. 126 | Such errors include the ones occured in the application of primitives, 127 | e.g., (car 0). To handle these errors, we have to check if the 128 | application of primitives leads to an error every time a primitive is 129 | applied. Because it would make the apply procedure much longer and 130 | tedious, we do not remedy this but leave it as an alternative way to 131 | quit the Black system. 132 | 133 | For questions, comments, etc., contact asai@is.s.u-tokyo.ac.jp. 134 | 135 | References 136 | 137 | [1] Kenichi Asai, Satoshi Matsuoka, and Akinori Yonezawa 138 | "Duplication and Partial Evaluation 139 | --- For a Better Understanding of Reflective Languages ---" 140 | Lisp and Symbolic Computation, 9, pp.203-241, Kluwer Academic 141 | Publishers, Boston (1996). 142 | 143 | [2] Olivier Danvy and Karoline Malmkjaer 144 | "Intensions and Extensions in a Reflective Tower" 145 | Lisp and Functional Programming, pp.327-341 (1988). 146 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Black 2 | 3 | This is the source code for [Kenichi Asai](http://pllab.is.ocha.ac.jp/~asai/)'s Black programming language as described in the paper *Duplication and Partial Evaluation - For a Better Understanding of Reflective Languages*. Please see [the original README](/README) from the [black.tar.gz](http://pllab.is.ocha.ac.jp/~asai/papers/black.tar.gz) code archive accompanying the paper. 4 | 5 | # Getting Started 6 | 7 | ```scheme 8 | (load "env.scm") 9 | (load "stream.scm") 10 | (define scheme-apply apply) 11 | (load "black.scm") 12 | (black) 13 | ``` 14 | 15 | See the [examples](examples/transcript.scm). 16 | Play in your browser at [io.livecode.ch](http://io.livecode.ch/learn/readevalprintlove/black)! 17 | -------------------------------------------------------------------------------- /black-with-delta.scm: -------------------------------------------------------------------------------- 1 | (define scheme-apply apply) 2 | ; 3 | ; Eval functions 4 | ; 5 | (define (base-eval exp env cont) 6 | (cond ((number? exp) (meta-apply cont exp)) 7 | ((boolean? exp) (meta-apply cont exp)) 8 | ((string? exp) (meta-apply cont exp)) 9 | ((symbol? exp) (meta-apply 'eval-var exp env cont)) 10 | ((eq? (car exp) 'quote) (meta-apply 'eval-quote exp env cont)) 11 | ((eq? (car exp) 'if) (meta-apply 'eval-if exp env cont)) 12 | ((eq? (car exp) 'cond) (meta-apply 'eval-cond (cdr exp) env cont)) 13 | ((eq? (car exp) 'define) (meta-apply 'eval-define exp env cont)) 14 | ((eq? (car exp) 'set!) (meta-apply 'eval-set! exp env cont)) 15 | ((eq? (car exp) 'lambda) (meta-apply 'eval-lambda exp env cont)) 16 | ((eq? (car exp) 'delta) (meta-apply 'eval-delta exp env cont)) 17 | ((eq? (car exp) 'begin) (meta-apply 'eval-begin (cdr exp) env cont)) 18 | ((eq? (car exp) 'let) (meta-apply 'eval-let 19 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 20 | ((eq? (car exp) 'let*) (meta-apply 'eval-let* 21 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 22 | ((eq? (car exp) 'letrec) (meta-apply 'eval-letrec 23 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 24 | ((eq? (car exp) 'EM) (meta-apply 'eval-EM exp env cont)) 25 | ((eq? (car exp) 'exec-at-metalevel) 26 | (meta-apply 'eval-EM exp env cont)) 27 | ((eq? (car exp) 'exit) (meta-apply 'eval-exit exp env cont)) 28 | ((eq? (car exp) 'load) (meta-apply 'eval-load exp env cont)) 29 | ((eq? (car exp) 'and) (meta-apply 'eval-and (cdr exp) env cont)) 30 | ((eq? (car exp) 'or) (meta-apply 'eval-or (cdr exp) env cont)) 31 | (else (meta-apply 'eval-application exp env cont)))) 32 | (define (eval-application exp env cont) 33 | (meta-apply 'base-eval (car exp) env 34 | (lambda (operator) 35 | (if (and (pair? operator) (eq? (car operator) delta-tag)) 36 | (meta-apply 'apply-delta operator (cdr exp) env cont) 37 | (meta-apply 'eval-list (cdr exp) env 38 | (lambda (operand) 39 | (meta-apply 'base-apply 40 | operator operand env cont))))))) 41 | (define (eval-var exp env cont) 42 | (let ((pair (get exp env))) 43 | (if (pair? pair) 44 | (meta-apply cont (cdr pair)) 45 | (meta-apply 'my-error 46 | (list 'eval-var: 'unbound 'variable: exp) env cont)))) 47 | (define (eval-quote exp env cont) (meta-apply cont (car (cdr exp)))) 48 | (define (eval-if exp env cont) 49 | (let ((pred-part (car (cdr exp))) 50 | (then-part (car (cdr (cdr exp)))) 51 | (else-part (cdr (cdr (cdr exp))))) 52 | (meta-apply 'base-eval pred-part env (lambda (p) 53 | (cond (p (meta-apply 'base-eval then-part env cont)) 54 | ((null? else-part) (meta-apply cont #f)) 55 | (else 56 | (meta-apply 'base-eval (car else-part) env cont))))))) 57 | (define (eval-cond clauses env cont) 58 | (cond ((null? clauses) (meta-apply cont '())) 59 | ((eq? (car (car clauses)) 'else) 60 | (meta-apply 'eval-begin (cdr (car clauses)) env cont)) 61 | (else 62 | (meta-apply 'base-eval 63 | (car (car clauses)) 64 | env 65 | (lambda (pred) 66 | (if pred 67 | (meta-apply 'eval-begin (cdr (car clauses)) 68 | env cont) 69 | (meta-apply 'eval-cond (cdr clauses) 70 | env cont))))))) 71 | (define (eval-define exp env cont) 72 | (if (pair? (car (cdr exp))) 73 | (let ((var (car (car (cdr exp)))) 74 | (body (cons 'lambda 75 | (cons (cdr (car (cdr exp))) 76 | (cdr (cdr exp)))))) 77 | (meta-apply 'base-eval body env 78 | (lambda (data) 79 | (define-value var data env) 80 | (meta-apply cont var)))) 81 | (let ((var (car (cdr exp))) 82 | (body (car (cdr (cdr exp))))) 83 | (meta-apply 'base-eval body env 84 | (lambda (data) 85 | (define-value var data env) 86 | (meta-apply cont var)))))) 87 | (define (eval-set! exp env cont) 88 | (let ((var (car (cdr exp))) 89 | (body (car (cdr (cdr exp))))) 90 | (meta-apply 'base-eval body env 91 | (lambda (data) 92 | (let ((pair (get var env))) 93 | (if (pair? pair) 94 | (begin (set-value! var data env) 95 | (meta-apply cont var)) 96 | (meta-apply 'my-error 97 | (list 'eval-set!: 'unbound 'variable var) 98 | env cont))))))) 99 | (define lambda-tag (cons 'lambda 'tag)) 100 | (define (eval-lambda exp env cont) 101 | (let ((lambda-body (cdr (cdr exp))) 102 | (lambda-params (car (cdr exp)))) 103 | (meta-apply cont (list lambda-tag lambda-params lambda-body env)))) 104 | (define delta-tag (cons 'delta 'tag)) 105 | (define (eval-delta exp env cont) 106 | (let ((delta-body (cdr (cdr exp))) 107 | (delta-params (car (cdr exp)))) 108 | (meta-apply cont (list delta-tag delta-params delta-body)))) 109 | (define (eval-begin body env cont) 110 | (define (eval-begin-local body) 111 | (if (null? (cdr body)) 112 | (meta-apply 'base-eval (car body) env cont) 113 | (meta-apply 'base-eval (car body) env 114 | (lambda (x) (eval-begin-local (cdr body)))))) 115 | (if (null? body) 116 | (meta-apply 'my-error '(eval-begin: null body) env cont) 117 | (eval-begin-local body))) 118 | (define (eval-let pairs body env cont) 119 | (let ((params (map car pairs)) 120 | (args (map (lambda (x) (car (cdr x))) pairs))) 121 | (meta-apply 'eval-list args env 122 | (lambda (operand) 123 | (meta-apply 'eval-begin body 124 | (extend env params operand) 125 | cont))))) 126 | (define (eval-let* pairs body env cont) 127 | (if (null? pairs) 128 | (meta-apply 'eval-begin body env cont) 129 | (meta-apply 'base-eval (car (cdr (car pairs))) env (lambda (arg) 130 | (meta-apply 'eval-let* (cdr pairs) body 131 | (extend env (list (car (car pairs))) (list arg)) 132 | cont))))) 133 | (define (eval-letrec pairs body env cont) 134 | (define (set-value-list! params operand env) 135 | (if (null? params) 136 | #f 137 | (begin (set-value! (car params) (car operand) env) 138 | (set-value-list! (cdr params) (cdr operand) env)))) 139 | (let ((params (map car pairs)) 140 | (args (map (lambda (x) (car (cdr x))) pairs))) 141 | (let ((letrec-env (extend env params params))) 142 | (meta-apply 'eval-list args letrec-env 143 | (lambda (operand) 144 | (set-value-list! params operand letrec-env) 145 | (meta-apply 'eval-begin body letrec-env cont)))))) 146 | (define (eval-EM exp env cont) 147 | (lambda (Mcont) 148 | (let ((meta-env (car (head Mcont))) 149 | (meta-cont (car (cdr (head Mcont)))) 150 | (meta-Mcont (tail Mcont))) 151 | ((meta-apply 'base-eval 152 | (car (cdr exp)) 153 | meta-env 154 | (lambda (ans) (lambda (Mcont2) 155 | ((meta-apply cont ans) 156 | (cons-stream (head Mcont) Mcont2))))) 157 | meta-Mcont)))) 158 | (define (eval-exit exp env cont) 159 | (meta-apply 'base-eval (car (cdr exp)) env 160 | (lambda (x) (meta-apply 'my-error x env cont)))) 161 | (define (eval-list exp env cont) 162 | (if (null? exp) 163 | (meta-apply cont '()) 164 | (meta-apply 'base-eval (car exp) env 165 | (lambda (val1) 166 | (meta-apply 'eval-list (cdr exp) env 167 | (lambda (val2) 168 | (meta-apply cont (cons val1 val2)))))))) 169 | (define (base-apply operator operand env cont) 170 | (cond ((procedure? operator) 171 | (cond ((eq? operator map) 172 | (meta-apply 'eval-map 173 | (car operand) (car (cdr operand)) env cont)) 174 | ((eq? operator scheme-apply) 175 | (meta-apply 'base-apply 176 | (car operand) (car (cdr operand)) env cont)) 177 | ((pair? (member operator primitive-procedures)) 178 | (meta-apply cont (scheme-apply operator operand))) 179 | (else ; called when going down a level. 180 | (lambda (Mcont) 181 | ((scheme-apply operator operand) 182 | (cons-stream (list (get-global-env env) cont) Mcont)))))) 183 | ((and (pair? operator) 184 | (eq? (car operator) lambda-tag)) 185 | (let ((lambda-params (car (cdr operator))) 186 | (lambda-body (car (cdr (cdr operator)))) 187 | (lambda-env (car (cdr (cdr (cdr operator)))))) 188 | (if (can-receive? lambda-params operand) 189 | (meta-apply 'eval-begin 190 | lambda-body 191 | (extend lambda-env lambda-params operand) 192 | cont) 193 | (meta-apply 'my-error 194 | (list 'base-apply: 'Wrong 'number 'of 'arguments: 195 | operand 'to: lambda-params) 196 | env cont)))) 197 | (else 198 | (meta-apply 'my-error (list 'Not 'a 'function: operator) env cont)))) 199 | (define (apply-delta operator operand env cont) 200 | (lambda (Mcont) 201 | (let ((meta-env (car (head Mcont))) 202 | (meta-cont (car (cdr (head Mcont)))) 203 | (meta-Mcont (tail Mcont))) 204 | (let ((delta-params (car (cdr operator))) 205 | (delta-body (car (cdr (cdr operator))))) 206 | ((meta-apply 'eval-begin 207 | delta-body 208 | (extend meta-env delta-params (list operand env cont)) 209 | meta-cont) 210 | meta-Mcont))))) 211 | (define old-env 0) 212 | (define old-cont 0) 213 | (define (my-error exp env cont) 214 | (lambda (Mcont) 215 | (let ((meta-env (car (head Mcont))) 216 | (meta-cont (car (cdr (head Mcont)))) 217 | (meta-Mcont (tail Mcont))) 218 | (set-value! 'old-env env meta-env) 219 | (set-value! 'old-cont cont meta-env) 220 | ((meta-apply meta-cont exp) meta-Mcont)))) 221 | (define (eval-load exp env cont) 222 | (define port (open-input-file (car (cdr exp)))) 223 | (define (load-local) 224 | (let ((input (read port))) 225 | (if (eof-object? input) 226 | (begin (close-input-port port) 227 | (meta-apply cont 'done)) 228 | (meta-apply 'base-eval input env 229 | (lambda (value) (load-local)))))) 230 | (load-local)) 231 | (define (eval-and body env cont) 232 | (cond ((null? body) (meta-apply cont #t)) 233 | ((null? (cdr body)) 234 | (meta-apply 'base-eval (car body) env cont)) 235 | (else 236 | (meta-apply 'base-eval (car body) env 237 | (lambda (result) 238 | (if result 239 | (meta-apply 'eval-and (cdr body) env cont) 240 | (meta-apply cont result))))))) 241 | (define (eval-or body env cont) 242 | (if (null? body) 243 | (meta-apply cont #f) 244 | (meta-apply 'base-eval (car body) env 245 | (lambda (result) 246 | (if result 247 | (meta-apply cont result) 248 | (meta-apply 'eval-or (cdr body) env cont)))))) 249 | ; 250 | ; Primitives 251 | ; 252 | (define (eval-map fun lst env cont) 253 | (if (null? lst) 254 | (meta-apply cont '()) 255 | (meta-apply 'base-apply fun (list (car lst)) env 256 | (lambda (x) (meta-apply 'eval-map fun (cdr lst) env 257 | (lambda (y) (meta-apply cont (cons x y)))))))) 258 | (define (primitive-procedure? . operand) 259 | (let ((arg (car operand))) 260 | (or (procedure? arg) 261 | (and (pair? arg) 262 | (eq? (car arg) lambda-tag))))) 263 | (define (primitive-output write args) 264 | (let ((answer (car args))) 265 | (if (and (pair? answer) 266 | (eq? (car answer) lambda-tag)) 267 | (let ((lambda-params (car (cdr answer))) 268 | (lambda-body (car (cdr (cdr answer)))) 269 | (lambda-env (car (cdr (cdr (cdr answer)))))) 270 | (write (cons 'lambda (cons lambda-params lambda-body)))) 271 | (write answer)))) 272 | (define (primitive-display . args) 273 | (primitive-output display args)) 274 | (define (primitive-write . args) 275 | (primitive-output write args)) 276 | (define (primitive-pp . args) 277 | (primitive-output pp args)) 278 | (define (primitive-print lst depth length) 279 | (define (print-sub lst d l top?) 280 | (cond ((pair? lst) 281 | (cond ((= l 0) 282 | (if top? (display "(...)") (display " ...)"))) 283 | ((= d 0) (display "#")) 284 | (else 285 | (if top? (display "(") (display " ")) 286 | (print-sub (car lst) (- d 1) length #t) 287 | (cond ((pair? (cdr lst)) 288 | (print-sub (cdr lst) d (- l 1) #f)) 289 | ((null? (cdr lst)) 290 | (display ")")) 291 | (else 292 | (begin (display " . ") 293 | (print-sub (cdr lst) d (- l 1) #f) 294 | (display ")"))))))) 295 | (else (display lst)))) 296 | (print-sub lst depth length #t)) 297 | ; 298 | ; Meta-apply 299 | ; 300 | (define (meta-apply proc-name-or-cont . operand) 301 | (lambda (Mcont) 302 | (let ((meta-env (car (head Mcont))) 303 | (meta-cont (car (cdr (head Mcont)))) 304 | (meta-Mcont (tail Mcont))) 305 | (let ((operator (if (symbol? proc-name-or-cont) 306 | (cdr (get proc-name-or-cont meta-env)) 307 | proc-name-or-cont))) 308 | (cond ((procedure? operator) 309 | (cond ((pair? (member operator primitive-procedures)) 310 | ((meta-apply 'base-apply operator operand meta-env meta-cont) 311 | meta-Mcont)) 312 | (else ; evaluator functions 313 | ((scheme-apply operator operand) Mcont)))) 314 | (else 315 | ((meta-apply 'base-apply operator operand meta-env meta-cont) 316 | meta-Mcont))))))) 317 | ; 318 | ; Initial Continuation 319 | ; 320 | (define (init-cont env level turn cont) 321 | (meta-apply cont 322 | (lambda (answer) 323 | (write level)(write '-)(write turn)(display ": ") 324 | (primitive-write answer) 325 | (newline) 326 | (write level)(write '-)(write (+ turn 1))(display "> ") 327 | (meta-apply 'base-eval (read) env 328 | (lambda (ans) 329 | (meta-apply 'init-cont env level (+ turn 1) 330 | (lambda (cont) (meta-apply cont ans)))))))) 331 | 332 | (define (run env level answer) 333 | (meta-apply 'init-cont env level 0 334 | (lambda (cont) (meta-apply cont answer)))) 335 | ; 336 | ; Environment 337 | ; 338 | ;(load "env.scm") 339 | ; 340 | ; Primitive Procedures 341 | ; 342 | (define primitive-procedures 343 | (list car cdr cons list pair? null? eq? eqv? equal? not set-car! set-cdr! 344 | append 345 | primitive-write primitive-pp primitive-display newline read 346 | primitive-print primitive-procedure? 347 | + - * / = < > quotient remainder number? 348 | boolean? string? symbol? assq member length 349 | open-input-file close-input-port eof-object? 350 | map scheme-apply 351 | make-pairs extend can-receive? get set-value! define-value 352 | search copy 353 | )) 354 | ; 355 | ; Initial Environment 356 | ; 357 | (define init-env (list (list 358 | (cons 'car car) 359 | (cons 'cdr cdr) 360 | (cons 'cons cons) 361 | (cons 'list list) 362 | (cons 'pair? pair?) 363 | (cons 'null? null?) 364 | (cons 'eq? eq?) 365 | (cons 'eqv? eqv?) 366 | (cons 'equal? equal?) 367 | (cons 'not not) 368 | (cons 'set-car! set-car!) 369 | (cons 'set-cdr! set-cdr!) 370 | (cons 'append append) 371 | (cons 'write primitive-write) 372 | (cons 'pp primitive-pp) 373 | (cons 'display primitive-display) 374 | (cons 'print primitive-print) 375 | (cons 'newline newline) 376 | (cons 'read read) 377 | (cons '+ +) 378 | (cons '- -) 379 | (cons '* *) 380 | (cons '/ /) 381 | (cons '= =) 382 | (cons '> >) 383 | (cons '< <) 384 | (cons 'quotient quotient) 385 | (cons 'remainder remainder) 386 | (cons 'number? number?) 387 | (cons 'boolean? boolean?) 388 | (cons 'string? string?) 389 | (cons 'symbol? symbol?) 390 | (cons 'procedure? primitive-procedure?) 391 | (cons 'assq assq) 392 | (cons 'member member) 393 | (cons 'length length) 394 | (cons 'open-input-file open-input-file) 395 | (cons 'close-input-port close-input-port) 396 | (cons 'eof-object? eof-object?) 397 | 398 | (cons 'map map) 399 | (cons 'scheme-apply scheme-apply) 400 | 401 | (cons 'empty-env empty-env) 402 | (cons 'make-pairs make-pairs) 403 | (cons 'extend extend) 404 | (cons 'can-receive? can-receive?) 405 | (cons 'get get) 406 | (cons 'set-value! set-value!) 407 | (cons 'define-value define-value) 408 | (cons 'search search) 409 | (cons 'copy copy) 410 | 411 | (cons 'base-eval base-eval) 412 | (cons 'eval-application eval-application) 413 | (cons 'eval-var eval-var) 414 | (cons 'eval-quote eval-quote) 415 | (cons 'eval-if eval-if) 416 | (cons 'eval-cond eval-cond) 417 | (cons 'eval-define eval-define) 418 | (cons 'eval-set! eval-set!) 419 | (cons 'lambda-tag lambda-tag) 420 | (cons 'eval-lambda eval-lambda) 421 | (cons 'delta-tag delta-tag) 422 | (cons 'eval-delta eval-delta) 423 | (cons 'eval-begin eval-begin) 424 | (cons 'eval-let eval-let) 425 | (cons 'eval-let* eval-let*) 426 | (cons 'eval-letrec eval-letrec) 427 | (cons 'eval-EM eval-EM) 428 | (cons 'eval-exit eval-exit) 429 | (cons 'eval-list eval-list) 430 | (cons 'base-apply base-apply) 431 | (cons 'apply-delta apply-delta) 432 | (cons 'my-error my-error) 433 | (cons 'eval-load eval-load) 434 | (cons 'eval-and eval-and) 435 | (cons 'eval-or eval-or) 436 | (cons 'eval-map eval-map) 437 | 438 | (cons 'init-env 0) ; to be filled when making a new level 439 | (cons 'init-cont init-cont) 440 | (cons 'run run) 441 | (cons 'primitive-procedures primitive-procedures) 442 | (cons 'old-env old-env) 443 | (cons 'old-cont old-cont) 444 | ))) 445 | ; 446 | ; Meta-level Initial Continuation 447 | ; 448 | ;(define (return result) 449 | ; (lambda (Mcont) 450 | ; (let ((meta-env (car (head Mcont))) 451 | ; (meta-cont (car (cdr (head Mcont)))) 452 | ; (meta-Mcont (tail Mcont))) 453 | ; ((meta-apply meta-cont result) 454 | ; meta-Mcont)))) 455 | (define (meta-init-cont env level supplied-env) 456 | (define-value 'init-env supplied-env env) ; share-env 457 | (display "New level loaded.")(newline) 458 | (lambda (result) 459 | (meta-apply 'run env level result))) 460 | ; 461 | ; Initial Meta-Continuation 462 | ; 463 | (define (init-Mcont level supplied-env) 464 | (let ((env (copy init-env))) 465 | (cons-stream (list env (meta-init-cont env level supplied-env)) 466 | (init-Mcont (+ level 1) env)))) 467 | ; 468 | ; Start up 469 | ; 470 | (define (black) 471 | (let* ((base-Mcont (init-Mcont 0 (copy init-env))) 472 | (env (car (head base-Mcont))) 473 | (cont (car (cdr (head base-Mcont)))) 474 | (Mcont (tail base-Mcont))) 475 | ((cont 'start) Mcont))) 476 | 477 | ;(newline) 478 | ;(black) 479 | -------------------------------------------------------------------------------- /black.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ; Eval functions 3 | ; 4 | (define (base-eval exp env cont) 5 | (cond ((number? exp) (meta-apply cont exp)) 6 | ((boolean? exp) (meta-apply cont exp)) 7 | ((string? exp) (meta-apply cont exp)) 8 | ((symbol? exp) (meta-apply 'eval-var exp env cont)) 9 | ((eq? (car exp) 'quote) (meta-apply 'eval-quote exp env cont)) 10 | ((eq? (car exp) 'if) (meta-apply 'eval-if exp env cont)) 11 | ((eq? (car exp) 'cond) (meta-apply 'eval-cond (cdr exp) env cont)) 12 | ((eq? (car exp) 'define) (meta-apply 'eval-define exp env cont)) 13 | ((eq? (car exp) 'set!) (meta-apply 'eval-set! exp env cont)) 14 | ((eq? (car exp) 'lambda) (meta-apply 'eval-lambda exp env cont)) 15 | ((eq? (car exp) 'begin) (meta-apply 'eval-begin (cdr exp) env cont)) 16 | ((eq? (car exp) 'let) (meta-apply 'eval-let 17 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 18 | ((eq? (car exp) 'let*) (meta-apply 'eval-let* 19 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 20 | ((eq? (car exp) 'letrec) (meta-apply 'eval-letrec 21 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 22 | ((eq? (car exp) 'EM) (meta-apply 'eval-EM exp env cont)) 23 | ((eq? (car exp) 'exec-at-metalevel) 24 | (meta-apply 'eval-EM exp env cont)) 25 | ((eq? (car exp) 'primitive-EM) 26 | (meta-apply 'eval-primitive-EM exp env cont)) 27 | ((eq? (car exp) 'exit) (meta-apply 'eval-exit exp env cont)) 28 | ((eq? (car exp) 'load) (meta-apply 'eval-load exp env cont)) 29 | ((eq? (car exp) 'and) (meta-apply 'eval-and (cdr exp) env cont)) 30 | ((eq? (car exp) 'or) (meta-apply 'eval-or (cdr exp) env cont)) 31 | ((eq? (car exp) 'delay) (meta-apply 'eval-delay exp env cont)) 32 | ((eq? (car exp) 'cons-stream) 33 | (meta-apply 'eval-cons-stream exp env cont)) 34 | (else (meta-apply 'eval-application exp env cont)))) 35 | (define (eval-application exp env cont) 36 | (meta-apply 'eval-list exp env 37 | (lambda (l) (meta-apply 'base-apply (car l) (cdr l) env cont)))) 38 | (define (eval-var exp env cont) 39 | (let ((pair (get exp env))) 40 | (if (pair? pair) 41 | (meta-apply cont (cdr pair)) 42 | (meta-apply 'my-error 43 | (list 'eval-var: 'unbound 'variable: exp) env cont)))) 44 | (define (eval-quote exp env cont) (meta-apply cont (car (cdr exp)))) 45 | (define (eval-if exp env cont) 46 | (let ((pred-part (car (cdr exp))) 47 | (then-part (car (cdr (cdr exp)))) 48 | (else-part (cdr (cdr (cdr exp))))) 49 | (meta-apply 'base-eval pred-part env (lambda (p) 50 | (cond (p (meta-apply 'base-eval then-part env cont)) 51 | ((null? else-part) (meta-apply cont #f)) 52 | (else 53 | (meta-apply 'base-eval (car else-part) env cont))))))) 54 | (define (eval-cond clauses env cont) 55 | (cond ((null? clauses) (meta-apply cont '())) 56 | ((eq? (car (car clauses)) 'else) 57 | (meta-apply 'eval-begin (cdr (car clauses)) env cont)) 58 | (else 59 | (meta-apply 'base-eval 60 | (car (car clauses)) 61 | env 62 | (lambda (pred) 63 | (if pred 64 | (meta-apply 'eval-begin (cdr (car clauses)) 65 | env cont) 66 | (meta-apply 'eval-cond (cdr clauses) 67 | env cont))))))) 68 | (define (eval-define exp env cont) 69 | (if (pair? (car (cdr exp))) 70 | (let ((var (car (car (cdr exp)))) 71 | (body (cons 'lambda 72 | (cons (cdr (car (cdr exp))) 73 | (cdr (cdr exp)))))) 74 | (meta-apply 'base-eval body env 75 | (lambda (data) 76 | (define-value var data env) 77 | (meta-apply cont var)))) 78 | (let ((var (car (cdr exp))) 79 | (body (car (cdr (cdr exp))))) 80 | (meta-apply 'base-eval body env 81 | (lambda (data) 82 | (define-value var data env) 83 | (meta-apply cont var)))))) 84 | (define (eval-set! exp env cont) 85 | (let ((var (car (cdr exp))) 86 | (body (car (cdr (cdr exp))))) 87 | (meta-apply 'base-eval body env 88 | (lambda (data) 89 | (let ((pair (get var env))) 90 | (if (pair? pair) 91 | (begin (set-value! var data env) 92 | (meta-apply cont var)) 93 | (meta-apply 'my-error 94 | (list 'eval-set!: 'unbound 'variable var) 95 | env cont))))))) 96 | (define lambda-tag (cons 'lambda 'tag)) 97 | (define (eval-lambda exp env cont) 98 | (let ((lambda-body (cdr (cdr exp))) 99 | (lambda-params (car (cdr exp)))) 100 | (meta-apply cont (list lambda-tag lambda-params lambda-body env)))) 101 | (define (eval-begin body env cont) 102 | (define (eval-begin-local body) 103 | (if (null? (cdr body)) 104 | (meta-apply 'base-eval (car body) env cont) 105 | (meta-apply 'base-eval (car body) env 106 | (lambda (x) (eval-begin-local (cdr body)))))) 107 | (if (null? body) 108 | (meta-apply 'my-error '(eval-begin: null body) env cont) 109 | (eval-begin-local body))) 110 | (define (eval-let pairs body env cont) 111 | (let ((params (map car pairs)) 112 | (args (map (lambda (x) (car (cdr x))) pairs))) 113 | (meta-apply 'eval-list args env 114 | (lambda (operand) 115 | (meta-apply 'eval-begin body 116 | (extend env params operand) 117 | cont))))) 118 | (define (eval-let* pairs body env cont) 119 | (if (null? pairs) 120 | (meta-apply 'eval-begin body env cont) 121 | (meta-apply 'base-eval (car (cdr (car pairs))) env (lambda (arg) 122 | (meta-apply 'eval-let* (cdr pairs) body 123 | (extend env (list (car (car pairs))) (list arg)) 124 | cont))))) 125 | (define (eval-letrec pairs body env cont) 126 | (define (set-value-list! params operand env) 127 | (if (null? params) 128 | #f 129 | (begin (set-value! (car params) (car operand) env) 130 | (set-value-list! (cdr params) (cdr operand) env)))) 131 | (let ((params (map car pairs)) 132 | (args (map (lambda (x) (car (cdr x))) pairs))) 133 | (let ((letrec-env (extend env params params))) 134 | (meta-apply 'eval-list args letrec-env 135 | (lambda (operand) 136 | (set-value-list! params operand letrec-env) 137 | (meta-apply 'eval-begin body letrec-env cont)))))) 138 | (define (eval-EM exp env cont) 139 | (lambda (Mcont) 140 | (let ((meta-env (car (head Mcont))) 141 | (meta-cont (car (cdr (head Mcont)))) 142 | (meta-Mcont (tail Mcont))) 143 | ((meta-apply 'base-eval 144 | (car (cdr exp)) 145 | meta-env 146 | (lambda (ans) (lambda (Mcont2) 147 | ((meta-apply cont ans) 148 | (cons-stream (head Mcont) Mcont2))))) 149 | meta-Mcont)))) 150 | (define (eval-primitive-EM exp env cont) 151 | (meta-apply 'base-eval (car (cdr exp)) env 152 | (lambda (body) (meta-apply 'eval-EM (list 'EM body) env cont)))) 153 | (define (eval-exit exp env cont) 154 | (meta-apply 'base-eval (car (cdr exp)) env 155 | (lambda (x) (meta-apply 'my-error x env cont)))) 156 | (define (eval-list exp env cont) 157 | (if (null? exp) 158 | (meta-apply cont '()) 159 | (meta-apply 'base-eval (car exp) env 160 | (lambda (val1) 161 | (meta-apply 'eval-list (cdr exp) env 162 | (lambda (val2) 163 | (meta-apply cont (cons val1 val2)))))))) 164 | (define (base-apply operator operand env cont) 165 | (cond ((procedure? operator) 166 | (cond ((eq? operator map) 167 | (meta-apply 'eval-map 168 | (car operand) (car (cdr operand)) env cont)) 169 | ((eq? operator scheme-apply) 170 | (meta-apply 'base-apply 171 | (car operand) (car (cdr operand)) env cont)) 172 | ((eq? operator force) 173 | (let ((arg (car operand))) 174 | (if (and (pair? arg) 175 | (eq? (car arg) delay-tag)) 176 | (let ((promise-body (car (cdr arg))) 177 | (promise-env (car (cdr (cdr arg)))) 178 | (pair (cdr (cdr arg)))) 179 | (if (pair? (cdr pair)) 180 | (meta-apply cont (car (cdr pair))) 181 | (meta-apply 'base-eval promise-body promise-env 182 | (lambda (ans) 183 | (set-cdr! pair (list ans)) 184 | (meta-apply cont ans))))) 185 | (meta-apply cont arg)))) 186 | ((pair? (member operator primitive-procedures)) 187 | (meta-apply cont (scheme-apply operator operand))) 188 | (else ; called when going down a level. 189 | (lambda (Mcont) 190 | ((scheme-apply operator operand) 191 | (cons-stream (list (get-global-env env) cont) Mcont)))))) 192 | ((and (pair? operator) 193 | (eq? (car operator) lambda-tag)) 194 | (let ((lambda-params (car (cdr operator))) 195 | (lambda-body (car (cdr (cdr operator)))) 196 | (lambda-env (car (cdr (cdr (cdr operator)))))) 197 | (if (can-receive? lambda-params operand) 198 | (meta-apply 'eval-begin 199 | lambda-body 200 | (extend lambda-env lambda-params operand) 201 | cont) 202 | (meta-apply 'my-error 203 | (list 'base-apply: 'Wrong 'number 'of 'arguments: 204 | operand 'to: lambda-params) 205 | env cont)))) 206 | (else 207 | (meta-apply 'my-error (list 'Not 'a 'function: operator) env cont)))) 208 | (define old-env 0) 209 | (define old-cont 0) 210 | (define (my-error exp env cont) 211 | (lambda (Mcont) 212 | (let ((meta-env (car (head Mcont))) 213 | (meta-cont (car (cdr (head Mcont)))) 214 | (meta-Mcont (tail Mcont))) 215 | (set-value! 'old-env env meta-env) 216 | (set-value! 'old-cont cont meta-env) 217 | ((meta-apply meta-cont exp) meta-Mcont)))) 218 | (define (eval-load exp env cont) 219 | (define port (open-input-file (car (cdr exp)))) 220 | (define (load-local) 221 | (let ((input (read port))) 222 | (if (eof-object? input) 223 | (begin (close-input-port port) 224 | (meta-apply cont 'done)) 225 | (meta-apply 'base-eval input env 226 | (lambda (value) (load-local)))))) 227 | (load-local)) 228 | (define (eval-and body env cont) 229 | (cond ((null? body) (meta-apply cont #t)) 230 | ((null? (cdr body)) 231 | (meta-apply 'base-eval (car body) env cont)) 232 | (else 233 | (meta-apply 'base-eval (car body) env 234 | (lambda (result) 235 | (if result 236 | (meta-apply 'eval-and (cdr body) env cont) 237 | (meta-apply cont result))))))) 238 | (define (eval-or body env cont) 239 | (if (null? body) 240 | (meta-apply cont #f) 241 | (meta-apply 'base-eval (car body) env 242 | (lambda (result) 243 | (if result 244 | (meta-apply cont result) 245 | (meta-apply 'eval-or (cdr body) env cont)))))) 246 | (define delay-tag (cons 'delay 'tag)) 247 | (define (eval-delay exp env cont) 248 | (let ((delay-body (car (cdr exp)))) 249 | (meta-apply cont (list delay-tag delay-body env)))) 250 | (define (eval-cons-stream exp env cont) 251 | (let ((car-part (car (cdr exp))) 252 | (cdr-part (car (cdr (cdr exp))))) 253 | (meta-apply 'base-eval (list 'cons car-part (list 'delay cdr-part)) 254 | env cont))) 255 | 256 | ; 257 | ; Primitives 258 | ; 259 | (define (eval-map fun lst env cont) 260 | (if (null? lst) 261 | (meta-apply cont '()) 262 | (meta-apply 'base-apply fun (list (car lst)) env 263 | (lambda (x) (meta-apply 'eval-map fun (cdr lst) env 264 | (lambda (y) (meta-apply cont (cons x y)))))))) 265 | (define (primitive-procedure? . operand) 266 | (let ((arg (car operand))) 267 | (or (procedure? arg) 268 | (and (pair? arg) 269 | (eq? (car arg) lambda-tag))))) 270 | (define (filter arg) 271 | (if (pair? arg) 272 | (cond ((eq? (car arg) lambda-tag) 273 | (let ((lambda-params (car (cdr arg))) 274 | (lambda-body (car (cdr (cdr arg))))) 275 | (cons 'lambda (cons lambda-params lambda-body)))) 276 | ((eq? (car arg) delay-tag) 277 | (let ((delay-body (car (cdr arg)))) 278 | (list ' delay-body))) 279 | (else 280 | (cons (filter (car arg)) 281 | (filter (cdr arg))))) 282 | arg)) 283 | (define (primitive-display . args) 284 | (display (filter (car args)))) 285 | (define (primitive-write . args) 286 | (write (filter (car args)))) 287 | (define (primitive-pp . args) 288 | (pp (filter (car args)))) 289 | (define (primitive-format . args) 290 | (apply format (map filter args))) 291 | (define (primitive-print lst depth length) 292 | (define (print-sub lst d l top?) 293 | (cond ((pair? lst) 294 | (cond ((= l 0) 295 | (if top? (display "(...)") (display " ...)"))) 296 | ((= d 0) (display "#")) 297 | (else 298 | (if top? (display "(") (display " ")) 299 | (print-sub (car lst) (- d 1) length #t) 300 | (cond ((pair? (cdr lst)) 301 | (print-sub (cdr lst) d (- l 1) #f)) 302 | ((null? (cdr lst)) 303 | (display ")")) 304 | (else 305 | (begin (display " . ") 306 | (print-sub (cdr lst) d (- l 1) #f) 307 | (display ")"))))))) 308 | (else (display lst)))) 309 | (print-sub lst depth length #t)) 310 | ; 311 | ; Meta-apply 312 | ; 313 | (define (meta-apply proc-name-or-cont . operand) 314 | (lambda (Mcont) 315 | (let* ((meta-env (car (head Mcont))) 316 | (meta-cont (car (cdr (head Mcont)))) 317 | (meta-Mcont (tail Mcont)) 318 | (operator (if (symbol? proc-name-or-cont) 319 | (cdr (get proc-name-or-cont meta-env)) 320 | proc-name-or-cont))) 321 | (cond ((procedure? operator) 322 | (if (pair? (member operator primitive-procedures)) 323 | ((meta-apply 'base-apply operator operand meta-env meta-cont) 324 | meta-Mcont) 325 | ((scheme-apply operator operand) ; evaluator functions 326 | Mcont))) 327 | (else 328 | ((meta-apply 'base-apply operator operand meta-env meta-cont) 329 | meta-Mcont)))))) 330 | ; 331 | ; Initial Continuation 332 | ; 333 | (define (init-cont env level turn cont) 334 | (meta-apply cont 335 | (lambda (answer) 336 | (write level) (write '-) (write turn) (display ": ") 337 | (primitive-write answer) 338 | (newline) 339 | (write level) (write '-) (write (+ turn 1)) (display "> ") 340 | (meta-apply 'base-eval (read) env 341 | (lambda (ans) 342 | (meta-apply 'init-cont env level (+ turn 1) 343 | (lambda (cont) (meta-apply cont ans)))))))) 344 | 345 | (define (run env level answer) 346 | (meta-apply 'init-cont env level 0 347 | (lambda (cont) (meta-apply cont answer)))) 348 | ; 349 | ; Environment 350 | ; 351 | ;(load "env.scm") 352 | ; 353 | ; Primitive Procedures 354 | ; 355 | (define primitive-procedures 356 | (list car cdr cons list pair? null? eq? eqv? equal? not set-car! set-cdr! 357 | append 358 | primitive-write primitive-pp primitive-display newline primitive-format read 359 | primitive-print primitive-procedure? 360 | + - * / = < > quotient remainder number? 361 | boolean? string? symbol? assq member length force 362 | open-input-file close-input-port eof-object? 363 | map scheme-apply 364 | make-pairs extend can-receive? get set-value! define-value 365 | search copy 366 | )) 367 | ; 368 | ; Initial Environment 369 | ; 370 | (define init-env (list (list 371 | (cons 'car car) 372 | (cons 'cdr cdr) 373 | (cons 'cons cons) 374 | (cons 'list list) 375 | (cons 'pair? pair?) 376 | (cons 'null? null?) 377 | (cons 'eq? eq?) 378 | (cons 'eqv? eqv?) 379 | (cons 'equal? equal?) 380 | (cons 'not not) 381 | (cons 'set-car! set-car!) 382 | (cons 'set-cdr! set-cdr!) 383 | (cons 'append append) 384 | (cons 'write primitive-write) 385 | (cons 'pp primitive-pp) 386 | (cons 'display primitive-display) 387 | (cons 'print primitive-print) 388 | (cons 'newline newline) 389 | (cons 'format primitive-format) 390 | (cons 'read read) 391 | (cons '+ +) 392 | (cons '- -) 393 | (cons '* *) 394 | (cons '/ /) 395 | (cons '= =) 396 | (cons '> >) 397 | (cons '< <) 398 | (cons 'quotient quotient) 399 | (cons 'remainder remainder) 400 | (cons 'number? number?) 401 | (cons 'boolean? boolean?) 402 | (cons 'string? string?) 403 | (cons 'symbol? symbol?) 404 | (cons 'procedure? primitive-procedure?) 405 | (cons 'assq assq) 406 | (cons 'member member) 407 | (cons 'length length) 408 | (cons 'force force) 409 | (cons 'open-input-file open-input-file) 410 | (cons 'close-input-port close-input-port) 411 | (cons 'eof-object? eof-object?) 412 | 413 | (cons 'map map) 414 | (cons 'scheme-apply scheme-apply) 415 | 416 | (cons 'empty-env empty-env) 417 | (cons 'make-pairs make-pairs) 418 | (cons 'extend extend) 419 | (cons 'can-receive? can-receive?) 420 | (cons 'get get) 421 | (cons 'set-value! set-value!) 422 | (cons 'define-value define-value) 423 | (cons 'search search) 424 | (cons 'copy copy) 425 | (cons 'get-global-env get-global-env) 426 | 427 | (cons 'base-eval base-eval) 428 | (cons 'eval-application eval-application) 429 | (cons 'eval-var eval-var) 430 | (cons 'eval-quote eval-quote) 431 | (cons 'eval-if eval-if) 432 | (cons 'eval-cond eval-cond) 433 | (cons 'eval-define eval-define) 434 | (cons 'eval-set! eval-set!) 435 | (cons 'lambda-tag lambda-tag) 436 | (cons 'eval-lambda eval-lambda) 437 | (cons 'eval-begin eval-begin) 438 | (cons 'eval-let eval-let) 439 | (cons 'eval-let* eval-let*) 440 | (cons 'eval-letrec eval-letrec) 441 | (cons 'eval-EM eval-EM) 442 | (cons 'eval-primitive-EM eval-primitive-EM) 443 | (cons 'eval-exit eval-exit) 444 | (cons 'eval-list eval-list) 445 | (cons 'base-apply base-apply) 446 | (cons 'my-error my-error) 447 | (cons 'eval-load eval-load) 448 | (cons 'eval-and eval-and) 449 | (cons 'eval-or eval-or) 450 | (cons 'delay-tag delay-tag) 451 | (cons 'eval-delay eval-delay) 452 | (cons 'eval-cons-stream eval-cons-stream) 453 | (cons 'eval-map eval-map) 454 | 455 | (cons 'init-env 0) ; to be filled when making a new level 456 | (cons 'init-cont init-cont) 457 | (cons 'run run) 458 | (cons 'primitive-procedures primitive-procedures) 459 | (cons 'old-env old-env) 460 | (cons 'old-cont old-cont) 461 | ))) 462 | ; 463 | ; Meta-level Initial Continuation 464 | ; 465 | (define (meta-init-cont env level supplied-env) 466 | (define-value 'init-env supplied-env env) ; share-env 467 | (display "New level loaded.") (newline) 468 | (lambda (result) 469 | (meta-apply 'run env level result))) 470 | ; 471 | ; Initial Meta-Continuation 472 | ; 473 | (define (init-Mcont level supplied-env) 474 | (let ((env (copy init-env))) 475 | (cons-stream (list env (meta-init-cont env level supplied-env)) 476 | (init-Mcont (+ level 1) env)))) 477 | ; 478 | ; Start up 479 | ; 480 | (define (black) 481 | (let* ((base-Mcont (init-Mcont 0 (copy init-env))) 482 | (env (car (head base-Mcont))) 483 | (cont (car (cdr (head base-Mcont)))) 484 | (Mcont (tail base-Mcont))) 485 | ((cont 'start) Mcont))) 486 | -------------------------------------------------------------------------------- /break.blk: -------------------------------------------------------------------------------- 1 | (define (loop prompt env ans) 2 | (write ans)(newline) 3 | (display prompt)(display "> ") 4 | (base-eval (read) env (lambda (ans) (loop prompt env ans)))) 5 | 6 | (define (eval-break pred env cont) 7 | (define (run-break-loop) 8 | (let ((result (loop "break" env 'break-loop))) 9 | (write 'break-end)(newline) 10 | (cont result))) 11 | (if (null? pred) 12 | (run-break-loop) 13 | (base-eval (car pred) env 14 | (lambda (pred) (if pred (run-break-loop) 15 | (cont #f)))))) 16 | 17 | (define (eval-inspect closure env cont) 18 | (base-eval closure env (lambda (closure) 19 | (let ((lambda-env (car (cdr (cdr (cdr closure)))))) 20 | (let ((result (loop "inspect" lambda-env 'inspect-loop))) 21 | (write 'inspect-end)(newline) 22 | (cont result)))))) 23 | 24 | (let ((original-eval-application eval-application)) 25 | (set! eval-application 26 | (lambda (exp env cont) 27 | (cond ((eq? (car exp) 'break) 28 | (eval-break (cdr exp) env cont)) 29 | ((eq? (car exp) 'inspect) 30 | (eval-inspect (car (cdr exp)) env cont)) 31 | (else 32 | (original-eval-application exp env cont)))))) 33 | -------------------------------------------------------------------------------- /compare: -------------------------------------------------------------------------------- 1 | # 2 | sed -e "s/meta-apply '//g" -e "s/meta-apply //g" black.scm > __tmp__ 3 | diff __tmp__ int.scm | less 4 | rm __tmp__ 5 | -------------------------------------------------------------------------------- /env.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ; Environment 3 | ; 4 | (define empty-env '(())) 5 | (define (make-pairs params args) 6 | (cond ((null? params) '()) 7 | ((symbol? params) (list (cons params args))) 8 | (else 9 | (cons (cons (car params) (car args)) 10 | (make-pairs (cdr params) (cdr args)))))) 11 | (define (extend env params args) 12 | (cons (make-pairs params args) env)) 13 | (define (can-receive? params args) 14 | (cond ((null? params) (null? args)) 15 | ((not (pair? params)) #t) 16 | ((pair? args) (can-receive? (cdr params) (cdr args))) 17 | (else #f))) 18 | (define (get var env) 19 | (if (null? env) 20 | '() 21 | (let ((pair (assq var (car env)))) 22 | (if (pair? pair) 23 | pair 24 | (get var (cdr env)))))) 25 | (define (set-value! var value env) 26 | (let ((pair (get var env))) 27 | (if (pair? pair) 28 | (set-cdr! pair value) 29 | (error 'set-value!: var 'is 'unbound)))) 30 | (define (define-value var value env) 31 | (let ((pair (assq var (car env)))) 32 | (if (pair? pair) 33 | (set-cdr! pair value) 34 | (set-car! env (cons (cons var value) (car env)))))) 35 | (define (search value env) 36 | (define (reverse-assq value env) 37 | (cond ((null? env) '()) 38 | ((eq? value (cdr (car env))) (car env)) 39 | (else (reverse-assq value (cdr env))))) 40 | (if (null? env) 41 | '() 42 | (let ((pair (reverse-assq value (car env)))) 43 | (if (pair? pair) 44 | pair 45 | (search value (cdr env)))))) 46 | (define (copy env) 47 | (define (copy-local env) 48 | (if (null? env) 49 | '() 50 | (cons (cons (car (car env)) 51 | (cdr (car env))) 52 | (copy-local (cdr env))))) 53 | (if (null? env) 54 | '() 55 | (cons (copy-local (car env)) 56 | (copy (cdr env))))) 57 | (define (get-global-env env) 58 | (define (get-global-env-local env) 59 | (if (null? (cdr env)) 60 | env 61 | (get-global-env-local (cdr env)))) 62 | (if (null? env) 63 | env 64 | (get-global-env-local env))) 65 | -------------------------------------------------------------------------------- /examples/church.scm: -------------------------------------------------------------------------------- 1 | ;; Church Booleans 2 | (define tru 3 | (lambda (t) (lambda (f) t))) 4 | 5 | (define fls 6 | (lambda (t) (lambda (f) f))) 7 | 8 | (define to_bool 9 | (lambda (b) (b #t #f))) 10 | 11 | ;; Pairs 12 | (define pair 13 | (lambda (f) (lambda (s) (lambda (b) ((b f) s))))) 14 | 15 | (define fst 16 | (lambda (p) (p tru))) 17 | 18 | (define snd 19 | (lambda (p) (p fls))) 20 | 21 | (define to_tuple 22 | (lambda (p) (cons (fst p) (snd p)))) 23 | 24 | (define c0 25 | (lambda (s) (lambda (z) z))) 26 | 27 | (define c1 28 | (lambda (s) (lambda (z) (s z)))) 29 | 30 | (define c2 31 | (lambda (s) (lambda (z) (s (s z))))) 32 | 33 | (define scc 34 | (lambda (n) (lambda (s) (lambda (z) (s ((n s) z)))))) 35 | 36 | (define to_int 37 | (lambda (n) ((n (lambda (v) (+ v 1))) 0))) 38 | 39 | (define iszro 40 | (lambda (n) ((n (lambda (x) fls)) tru))) 41 | 42 | (define plus 43 | (lambda (m) (lambda (n) (lambda (s) (lambda (z) ((m s) ((n s) z))))))) 44 | 45 | (define zz 46 | ((pair c0) c0)) 47 | 48 | (define ss 49 | (lambda (p) ((pair (snd p)) ((plus c1) (snd p))))) 50 | 51 | (define prd 52 | (lambda (n) (fst ((n ss) zz)))) 53 | 54 | (define prd-alt 55 | (lambda (n) (lambda (s) (lambda (z) (((n (lambda (g) (lambda (h) (h (g s))))) (lambda (u) z)) (lambda (u) u)))))) 56 | -------------------------------------------------------------------------------- /examples/cnv.scm: -------------------------------------------------------------------------------- 1 | (define zip 2 | (lambda (xs ys) 3 | (cond 4 | ((or (null? xs) (null? ys)) 5 | '()) 6 | (else 7 | (cons 8 | (cons (car xs) (car ys)) 9 | (zip (cdr xs) (cdr ys))))))) 10 | 11 | (define cnv2 12 | (lambda (xs ys) 13 | (define walk 14 | (lambda (xs k) 15 | (cond 16 | ((null? xs) 17 | (k '() ys)) 18 | (else 19 | (walk (cdr xs) 20 | (lambda (r ys) (k (cons (cons (car xs) (car ys)) r) 21 | (cdr ys)))))))) 22 | (walk xs (lambda (r ys) r)))) 23 | 24 | (define cnv3 25 | (lambda (xs ys) 26 | (define walk 27 | (lambda (xs) 28 | (cond 29 | ((null? xs) 30 | (cons '() ys)) 31 | (else 32 | (let ((rys (walk (cdr xs)))) 33 | (let ((r (car rys)) 34 | (ys (cdr rys))) 35 | (cons (cons (cons (car xs) (car ys)) r) 36 | (cdr ys)))))))) 37 | (car (walk xs)))) 38 | 39 | #; 40 | (begin 41 | (zip '(1 2 3) '(a b c)) 42 | (cnv2 '(1 2 3) '(a b c)) 43 | (cnv3 '(1 2 3) '(a b c)) 44 | ) 45 | -------------------------------------------------------------------------------- /examples/instr.blk: -------------------------------------------------------------------------------- 1 | (define eval-instr 2 | (lambda (exp env cont) 3 | (let ((original-eval-application eval-application) 4 | (instr-counter 0)) 5 | (set! eval-application 6 | (lambda (exp env cont) 7 | (set! instr-counter (+ instr-counter 1)) 8 | (original-eval-application exp env cont))) 9 | (base-eval exp env (lambda (ans) 10 | (set! eval-application original-eval-application) 11 | (display "#app: ") (write instr-counter) (newline) 12 | (cont ans)))))) 13 | 14 | (let ((original-eval-application eval-application)) 15 | (set! eval-application 16 | (lambda (exp env cont) 17 | (cond ((eq? (car exp) 'instr) 18 | (eval-instr (car (cdr exp)) env cont)) 19 | (else 20 | (original-eval-application exp env cont)))))) 21 | -------------------------------------------------------------------------------- /examples/instr2.blk: -------------------------------------------------------------------------------- 1 | (define eval-instr 2 | (lambda (exp env cont) 3 | (let ((restore-thunks '()) 4 | (total-counter 0) 5 | (display-msg (lambda (msg counter) 6 | (display "#") (display msg) (display ": ") 7 | (display counter) (newline)))) 8 | (let ((add-instr! 9 | (lambda (msg original set-original!) 10 | (let ((counter 0)) 11 | (set! restore-thunks 12 | (cons (lambda () 13 | (set! total-counter (+ total-counter counter)) 14 | (set-original! original) 15 | (display-msg msg counter)) 16 | restore-thunks)) 17 | (set-original! (lambda (exp env cont) 18 | (set! counter (+ counter 1)) 19 | (original exp env cont))))))) 20 | (add-instr! 'app eval-application (lambda (v) (set! eval-application v))) 21 | (add-instr! 'lam eval-lambda (lambda (v) (set! eval-lambda v))) 22 | (add-instr! 'var eval-var (lambda (v) (set! eval-var v)))) 23 | (base-eval exp env (lambda (ans) 24 | (newline) 25 | (map (lambda (t) (t)) restore-thunks) 26 | (display-msg 'total total-counter) 27 | (cont ans)))))) 28 | 29 | (let ((original-eval-application eval-application)) 30 | (set! eval-application 31 | (lambda (exp env cont) 32 | (cond ((eq? (car exp) 'instr) 33 | (eval-instr (car (cdr exp)) env cont)) 34 | (else 35 | (original-eval-application exp env cont)))))) 36 | -------------------------------------------------------------------------------- /examples/pal.scm: -------------------------------------------------------------------------------- 1 | (define pal_c 2 | (lambda (xs) 3 | (define walk 4 | (lambda (xs1 xs2 k) 5 | (cond 6 | ((and (null? xs2)) 7 | (k xs1)) 8 | ((null? (cdr xs2)) 9 | (k (cdr xs1))) 10 | (else 11 | (walk 12 | (cdr xs1) (cdr (cdr xs2)) 13 | (lambda (ys) 14 | (and (equal? (car xs1) (car ys)) 15 | (k (cdr ys))))))))) 16 | (walk xs xs (lambda (v) #t)))) 17 | 18 | #; 19 | (begin 20 | (pal_c '()) 21 | (pal_c '(1)) 22 | (pal_c '(1 2)) 23 | (pal_c '(1 2 2 1)) 24 | (pal_c '(1 2 1)) 25 | (pal_c '(1 2 3 1)) 26 | ) 27 | -------------------------------------------------------------------------------- /examples/stack.scm: -------------------------------------------------------------------------------- 1 | ;; works in MIT Scheme 2 | ;; need (load-option 'format) 3 | 4 | (define print-stack 5 | (lambda (es) 6 | (let ((m "~26A~26A~%")) 7 | (map ;; for-each 8 | (lambda (e) 9 | (let ((n (car e)) 10 | (down (car (cdr e))) 11 | (up (car (cdr (cdr e))))) 12 | 13 | (format #t m (cons n down) up) 14 | (format #t m "|" "^") 15 | (format #t m "V" "|"))) 16 | es) 17 | 18 | (format #t "---------------------------~%")))) 19 | 20 | -------------------------------------------------------------------------------- /examples/start.scm: -------------------------------------------------------------------------------- 1 | (load "env.scm") 2 | (load "stream.scm") 3 | (define scheme-apply apply) 4 | (load "black.scm") 5 | (black) 6 | -------------------------------------------------------------------------------- /examples/taba.blk: -------------------------------------------------------------------------------- 1 | (define eval-taba-call 2 | (lambda (original-eval-application) 3 | (lambda (exp env cont) 4 | (write 'taba-push:) 5 | (eval-list 6 | (cdr exp) env 7 | (lambda (ans-args) 8 | (write (cons (car exp) ans-args)) 9 | (newline) 10 | (original-eval-application 11 | exp env 12 | (lambda (ans) 13 | (write 'taba-pop:) 14 | (write ans) 15 | (newline) 16 | (cont ans)))))))) 17 | 18 | (define eval-taba 19 | (lambda (fns) 20 | (lambda (exp env cont) 21 | (let ((original-eval-application eval-application)) 22 | (map (lambda (fn) 23 | (add-app-hook! 24 | fn 25 | (eval-taba-call eval-application))) 26 | fns) 27 | (base-eval 28 | exp env 29 | (lambda (ans) 30 | (set! eval-application original-eval-application) 31 | (cont ans))))))) 32 | 33 | (add-app-hook! 34 | 'taba 35 | (lambda (exp env cont) 36 | ((eval-taba (car (cdr exp))) (car (cdr (cdr exp))) env cont))) 37 | -------------------------------------------------------------------------------- /examples/taba2.blk: -------------------------------------------------------------------------------- 1 | (define eval-taba-call 2 | (lambda (add! original-eval-application) 3 | (lambda (exp env cont) 4 | (eval-list 5 | (cdr exp) env 6 | (lambda (ans-args) 7 | (original-eval-application 8 | exp env 9 | (lambda (ans) 10 | (add! ans-args ans) 11 | (cont ans)))))))) 12 | 13 | (define eval-taba 14 | (lambda (fns) 15 | (lambda (exp env cont) 16 | (let ((original-eval-application eval-application) 17 | (stack '())) 18 | (map (lambda (fn) 19 | (add-app-hook! 20 | fn 21 | (eval-taba-call 22 | (lambda (ans-args ans) 23 | (set! stack (cons (list fn ans-args ans) stack))) 24 | eval-application))) 25 | fns) 26 | (base-eval 27 | exp env 28 | (lambda (ans) 29 | (set! eval-application original-eval-application) 30 | (cont 31 | (list ans stack)))))))) 32 | 33 | (add-app-hook! 34 | 'taba 35 | (lambda (exp env cont) 36 | ((eval-taba (car (cdr exp))) (car (cdr (cdr exp))) env cont))) 37 | -------------------------------------------------------------------------------- /examples/taba3.blk: -------------------------------------------------------------------------------- 1 | (define eval-taba-call 2 | (lambda (add! original-eval-application) 3 | (lambda (exp env cont) 4 | (eval-list 5 | (cdr exp) env 6 | (lambda (ans-args) 7 | (original-eval-application 8 | exp env 9 | (lambda (ans) 10 | (add! ans-args ans) 11 | (cont ans)))))))) 12 | 13 | (define eval-taba 14 | (lambda (fns) 15 | (lambda (exp env cont) 16 | (let ((original-eval-application eval-application) 17 | (stack '())) 18 | (map (lambda (fn) 19 | (add-app-hook! 20 | fn 21 | (eval-taba-call 22 | (lambda (ans-args ans) 23 | (set! stack (cons (list fn ans-args ans) stack))) 24 | eval-application))) 25 | fns) 26 | (base-eval 27 | exp env 28 | (lambda (ans) 29 | (set! eval-application original-eval-application) 30 | (print-stack stack) 31 | (cont ans))))))) 32 | 33 | (add-app-hook! 34 | 'taba 35 | (lambda (exp env cont) 36 | ((eval-taba (car (cdr exp))) (car (cdr (cdr exp))) env cont))) 37 | -------------------------------------------------------------------------------- /examples/transcript.scm: -------------------------------------------------------------------------------- 1 | ;; for MIT Scheme: 2 | (load-option 'format) 3 | 4 | ;; start running from the parent directory 5 | (load "env.scm") 6 | (load "stream.scm") 7 | (define scheme-apply apply) 8 | (load "black.scm") 9 | (black) 10 | 11 | (exec-at-metalevel 12 | (let ((old-eval base-eval)) 13 | (set! base-eval (lambda (exp env cont) 14 | (write 'trace:) (write exp) (newline) 15 | (old-eval exp env cont))))) 16 | 17 | (car (cons 1 2)) 18 | 19 | (exit 'bye) 20 | 21 | (exec-at-metalevel 22 | (load "break.blk")) 23 | 24 | (inspect base-eval) ;; works in Chez but not MIT or Chicken Scheme 25 | base-eval 26 | (exit 'good-bye) 27 | (old-cont 'hello) 28 | (+ 1 2) 29 | 30 | ;; resume with a different function at the lower level 31 | (define inc (lambda (x) (+ x 1))) 32 | (incr 2) ;; typo 33 | (base-eval 'inc old-env (lambda (x) x)) ;; see what inc is 34 | (base-eval 'inc old-env old-cont) ;; resume with inc for incr 35 | 36 | (load "examples/start.scm") 37 | 38 | ;; instrumentation 39 | (exec-at-metalevel 40 | (load "examples/instr.blk")) 41 | ;; or 42 | (exec-at-metalevel 43 | (load "examples/instr2.blk")) 44 | 45 | ;; Church Encoding 46 | ;; http://en.wikipedia.org/wiki/Church_encoding 47 | ;; Types and Programming Languages: section 5.2, Programming in the Lambda-Calculus 48 | (load "examples/church.scm") 49 | (instr (prd c2)) 50 | (instr (prd-alt c2)) 51 | (instr (to_int (prd-alt c2))) 52 | (instr (to_int (prd c2))) 53 | 54 | (load "examples/start.scm") 55 | (EM (load "examples/utils.blk")) 56 | ;; TABA: There And Back Again 57 | ;; http://www.brics.dk/RS/02/12/BRICS-RS-02-12.pdf (ICFP pearl) 58 | ;; http://brics.dk/RS/05/3/BRICS-RS-05-3.pdf (extended journal version) 59 | 60 | (EM (load "examples/taba.blk")) 61 | ;; or 62 | (EM (load "examples/taba2.blk")) 63 | ;; or 64 | (EM (load "examples/stack.scm")) 65 | (EM (load "examples/taba3.blk")) 66 | 67 | (load "examples/cnv.scm") 68 | (taba (cnv3 walk) (cnv3 '(1 2 3) '(a b c))) 69 | 70 | (load "examples/pal.scm") 71 | (taba (pal_c walk) (pal_c '(1 2 2 1))) 72 | -------------------------------------------------------------------------------- /examples/utils.blk: -------------------------------------------------------------------------------- 1 | (define add-app-hook! 2 | (lambda (n ev) 3 | (let ((original-eval-application eval-application)) 4 | (set! eval-application 5 | (lambda (exp env cont) 6 | (cond ((eq? (car exp) n) 7 | (ev exp env cont)) 8 | (else 9 | (original-eval-application exp env cont)))))))) 10 | -------------------------------------------------------------------------------- /init.scm: -------------------------------------------------------------------------------- 1 | (load "env.scm") 2 | (load "stream.scm") 3 | (define scheme-apply apply) 4 | (load "black.scm") 5 | (black) 6 | -------------------------------------------------------------------------------- /int.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ; Eval functions 3 | ; 4 | (define (base-eval exp env cont) 5 | (cond ((number? exp) (cont exp)) 6 | ((boolean? exp) (cont exp)) 7 | ((string? exp) (cont exp)) 8 | ((symbol? exp) (eval-var exp env cont)) 9 | ((eq? (car exp) 'quote) (eval-quote exp env cont)) 10 | ((eq? (car exp) 'if) (eval-if exp env cont)) 11 | ((eq? (car exp) 'cond) (eval-cond (cdr exp) env cont)) 12 | ((eq? (car exp) 'define) (eval-define exp env cont)) 13 | ((eq? (car exp) 'set!) (eval-set! exp env cont)) 14 | ((eq? (car exp) 'lambda) (eval-lambda exp env cont)) 15 | ((eq? (car exp) 'begin) (eval-begin (cdr exp) env cont)) 16 | ((eq? (car exp) 'let) (eval-let 17 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 18 | ((eq? (car exp) 'let*) (eval-let* 19 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 20 | ((eq? (car exp) 'letrec) (eval-letrec 21 | (car (cdr exp)) (cdr (cdr exp)) env cont)) 22 | ((eq? (car exp) 'EM) (eval-EM exp env cont)) 23 | ((eq? (car exp) 'exec-at-metalevel) 24 | (eval-EM exp env cont)) 25 | ((eq? (car exp) 'primitive-EM) 26 | (eval-primitive-EM exp env cont)) 27 | ((eq? (car exp) 'exit) (eval-exit exp env cont)) 28 | ((eq? (car exp) 'load) (eval-load exp env cont)) 29 | ((eq? (car exp) 'and) (eval-and (cdr exp) env cont)) 30 | ((eq? (car exp) 'or) (eval-or (cdr exp) env cont)) 31 | ((eq? (car exp) 'delay) (eval-delay exp env cont)) 32 | ((eq? (car exp) 'cons-stream) 33 | (eval-cons-stream exp env cont)) 34 | (else (eval-application exp env cont)))) 35 | (define (eval-application exp env cont) 36 | (eval-list exp env 37 | (lambda (l) (base-apply (car l) (cdr l) env cont)))) 38 | (define (eval-var exp env cont) 39 | (let ((pair (get exp env))) 40 | (if (pair? pair) 41 | (cont (cdr pair)) 42 | (my-error 43 | (list 'eval-var: 'unbound 'variable: exp) env cont)))) 44 | (define (eval-quote exp env cont) (cont (car (cdr exp)))) 45 | (define (eval-if exp env cont) 46 | (let ((pred-part (car (cdr exp))) 47 | (then-part (car (cdr (cdr exp)))) 48 | (else-part (cdr (cdr (cdr exp))))) 49 | (base-eval pred-part env (lambda (p) 50 | (cond (p (base-eval then-part env cont)) 51 | ((null? else-part) (cont #f)) 52 | (else 53 | (base-eval (car else-part) env cont))))))) 54 | (define (eval-cond clauses env cont) 55 | (cond ((null? clauses) (cont '())) 56 | ((eq? (car (car clauses)) 'else) 57 | (eval-begin (cdr (car clauses)) env cont)) 58 | (else 59 | (base-eval 60 | (car (car clauses)) 61 | env 62 | (lambda (pred) 63 | (if pred 64 | (eval-begin (cdr (car clauses)) 65 | env cont) 66 | (eval-cond (cdr clauses) 67 | env cont))))))) 68 | (define (eval-define exp env cont) 69 | (if (pair? (car (cdr exp))) 70 | (let ((var (car (car (cdr exp)))) 71 | (body (cons 'lambda 72 | (cons (cdr (car (cdr exp))) 73 | (cdr (cdr exp)))))) 74 | (base-eval body env 75 | (lambda (data) 76 | (define-value var data env) 77 | (cont var)))) 78 | (let ((var (car (cdr exp))) 79 | (body (car (cdr (cdr exp))))) 80 | (base-eval body env 81 | (lambda (data) 82 | (define-value var data env) 83 | (cont var)))))) 84 | (define (eval-set! exp env cont) 85 | (let ((var (car (cdr exp))) 86 | (body (car (cdr (cdr exp))))) 87 | (base-eval body env 88 | (lambda (data) 89 | (let ((pair (get var env))) 90 | (if (pair? pair) 91 | (begin (set-value! var data env) 92 | (cont var)) 93 | (my-error 94 | (list 'eval-set!: 'unbound 'variable var) 95 | env cont))))))) 96 | (define lambda-tag (cons 'lambda 'tag)) 97 | (define (eval-lambda exp env cont) 98 | (let ((lambda-body (cdr (cdr exp))) 99 | (lambda-params (car (cdr exp)))) 100 | (cont (list lambda-tag lambda-params lambda-body env)))) 101 | (define (eval-begin body env cont) 102 | (define (eval-begin-local body) 103 | (if (null? (cdr body)) 104 | (base-eval (car body) env cont) 105 | (base-eval (car body) env 106 | (lambda (x) (eval-begin-local (cdr body)))))) 107 | (if (null? body) 108 | (my-error '(eval-begin: null body) env cont) 109 | (eval-begin-local body))) 110 | (define (eval-let pairs body env cont) 111 | (let ((params (map car pairs)) 112 | (args (map (lambda (x) (car (cdr x))) pairs))) 113 | (eval-list args env 114 | (lambda (operand) 115 | (eval-begin body 116 | (extend env params operand) 117 | cont))))) 118 | (define (eval-let* pairs body env cont) 119 | (if (null? pairs) 120 | (eval-begin body env cont) 121 | (base-eval (car (cdr (car pairs))) env (lambda (arg) 122 | (eval-let* (cdr pairs) body 123 | (extend env (list (car (car pairs))) (list arg)) 124 | cont))))) 125 | (define (eval-letrec pairs body env cont) 126 | (define (set-value-list! params operand env) 127 | (if (null? params) 128 | #f 129 | (begin (set-value! (car params) (car operand) env) 130 | (set-value-list! (cdr params) (cdr operand) env)))) 131 | (let ((params (map car pairs)) 132 | (args (map (lambda (x) (car (cdr x))) pairs))) 133 | (let ((letrec-env (extend env params params))) 134 | (eval-list args letrec-env 135 | (lambda (operand) 136 | (set-value-list! params operand letrec-env) 137 | (eval-begin body letrec-env cont)))))) 138 | (define (eval-EM exp env cont) 139 | (cont (primitive-EM (car (cdr exp))))) 140 | (define (eval-primitive-EM exp env cont) 141 | (base-eval (car (cdr exp)) env 142 | (lambda (body) (cont (primitive-EM body))))) 143 | (define (eval-exit exp env cont) 144 | (base-eval (car (cdr exp)) env 145 | (lambda (x) (my-error x env cont)))) 146 | (define (eval-list exp env cont) 147 | (if (null? exp) 148 | (cont '()) 149 | (base-eval (car exp) env 150 | (lambda (val1) 151 | (eval-list (cdr exp) env 152 | (lambda (val2) 153 | (cont (cons val1 val2)))))))) 154 | (define (base-apply operator operand env cont) 155 | (cond ((procedure? operator) 156 | (cond ((eq? operator map) 157 | (eval-map 158 | (car operand) (car (cdr operand)) env cont)) 159 | ((eq? operator scheme-apply) 160 | (base-apply 161 | (car operand) (car (cdr operand)) env cont)) 162 | ((eq? operator force) 163 | (let ((arg (car operand))) 164 | (if (and (pair? arg) 165 | (eq? (car arg) delay-tag)) 166 | (let ((promise-body (car (cdr arg))) 167 | (promise-env (car (cdr (cdr arg)))) 168 | (pair (cdr (cdr arg)))) 169 | (if (pair? (cdr pair)) 170 | (cont (car (cdr pair))) 171 | (base-eval promise-body promise-env 172 | (lambda (ans) 173 | (set-cdr! pair (list ans)) 174 | (cont ans))))) 175 | (cont arg)))) 176 | ((pair? (member operator primitive-procedures)) 177 | (cont (scheme-apply operator operand))) 178 | (else ; called when going down a level. 179 | (cont (scheme-apply operator operand))))) 180 | ((and (pair? operator) 181 | (eq? (car operator) lambda-tag)) 182 | (let ((lambda-params (car (cdr operator))) 183 | (lambda-body (car (cdr (cdr operator)))) 184 | (lambda-env (car (cdr (cdr (cdr operator)))))) 185 | (if (can-receive? lambda-params operand) 186 | (eval-begin 187 | lambda-body 188 | (extend lambda-env lambda-params operand) 189 | cont) 190 | (my-error 191 | (list 'base-apply: 'Wrong 'number 'of 'arguments: 192 | operand 'to: lambda-params) 193 | env cont)))) 194 | (else 195 | (my-error (list 'Not 'a 'function: operator) env cont)))) 196 | (define old-env 0) 197 | (define old-cont 0) 198 | (define (my-error exp env cont) 199 | (set! old-env env) 200 | (set! old-cont cont) 201 | exp) 202 | (define (eval-load exp env cont) 203 | (define port (open-input-file (car (cdr exp)))) 204 | (define (load-local) 205 | (let ((input (read port))) 206 | (if (eof-object? input) 207 | (begin (close-input-port port) 208 | (cont 'done)) 209 | (base-eval input env 210 | (lambda (value) (load-local)))))) 211 | (load-local)) 212 | (define (eval-and body env cont) 213 | (cond ((null? body) (cont #t)) 214 | ((null? (cdr body)) 215 | (base-eval (car body) env cont)) 216 | (else 217 | (base-eval (car body) env 218 | (lambda (result) 219 | (if result 220 | (eval-and (cdr body) env cont) 221 | (cont result))))))) 222 | (define (eval-or body env cont) 223 | (if (null? body) 224 | (cont #f) 225 | (base-eval (car body) env 226 | (lambda (result) 227 | (if result 228 | (cont result) 229 | (eval-or (cdr body) env cont)))))) 230 | (define delay-tag (cons 'delay 'tag)) 231 | (define (eval-delay exp env cont) 232 | (let ((delay-body (car (cdr exp)))) 233 | (cont (list delay-tag delay-body env)))) 234 | (define (eval-cons-stream exp env cont) 235 | (let ((car-part (car (cdr exp))) 236 | (cdr-part (car (cdr (cdr exp))))) 237 | (base-eval (list 'cons car-part (list 'delay cdr-part)) 238 | env cont))) 239 | 240 | ; 241 | ; Primitives 242 | ; 243 | (define (eval-map fun lst env cont) 244 | (if (null? lst) 245 | (cont '()) 246 | (base-apply fun (list (car lst)) env 247 | (lambda (x) (eval-map fun (cdr lst) env 248 | (lambda (y) (cont (cons x y)))))))) 249 | (define (primitive-procedure? . operand) 250 | (let ((arg (car operand))) 251 | (or (procedure? arg) 252 | (and (pair? arg) 253 | (eq? (car arg) lambda-tag))))) 254 | (define (filter arg) 255 | (if (pair? arg) 256 | (cond ((eq? (car arg) lambda-tag) 257 | (let ((lambda-params (car (cdr arg))) 258 | (lambda-body (car (cdr (cdr arg))))) 259 | (cons 'lambda (cons lambda-params lambda-body)))) 260 | ((eq? (car arg) delay-tag) 261 | (let ((delay-body (car (cdr arg)))) 262 | (list ' delay-body))) 263 | (else 264 | (cons (filter (car arg)) 265 | (filter (cdr arg))))) 266 | arg)) 267 | (define (primitive-display . args) 268 | (display (filter (car args)))) 269 | (define (primitive-write . args) 270 | (write (filter (car args)))) 271 | (define (primitive-pp . args) 272 | (pp (filter (car args)))) 273 | (define (primitive-print lst depth length) 274 | (define (print-sub lst d l top?) 275 | (cond ((pair? lst) 276 | (cond ((= l 0) 277 | (if top? (display "(...)") (display " ...)"))) 278 | ((= d 0) (display "#")) 279 | (else 280 | (if top? (display "(") (display " ")) 281 | (print-sub (car lst) (- d 1) length #t) 282 | (cond ((pair? (cdr lst)) 283 | (print-sub (cdr lst) d (- l 1) #f)) 284 | ((null? (cdr lst)) 285 | (display ")")) 286 | (else 287 | (begin (display " . ") 288 | (print-sub (cdr lst) d (- l 1) #f) 289 | (display ")"))))))) 290 | (else (display lst)))) 291 | (print-sub lst depth length #t)) 292 | ; 293 | ; Initial Continuation 294 | ; 295 | (define (init-cont env level turn cont) 296 | (cont 297 | (lambda (answer) 298 | (write level) (write '-) (write turn) (display ": ") 299 | (primitive-write answer) 300 | (newline) 301 | (write level) (write '-) (write (+ turn 1)) (display "> ") 302 | (base-eval (read) env 303 | (lambda (ans) 304 | (init-cont env level (+ turn 1) 305 | (lambda (cont) (cont ans)))))))) 306 | 307 | (define (run env level answer) 308 | (init-cont env level 0 309 | (lambda (cont) (cont answer)))) 310 | ; 311 | ; Environment 312 | ; 313 | ;(load "env.scm") 314 | ; 315 | ; Primitive Procedures 316 | ; 317 | (define primitive-procedures 318 | (list car cdr cons list pair? null? eq? eqv? equal? not set-car! set-cdr! 319 | append 320 | primitive-write primitive-pp primitive-display newline read 321 | primitive-print primitive-procedure? 322 | + - * / = < > quotient remainder number? 323 | boolean? string? symbol? assq member length force 324 | open-input-file close-input-port eof-object? 325 | map scheme-apply 326 | make-pairs extend can-receive? get set-value! define-value 327 | search copy 328 | )) 329 | ; 330 | ; Initial Environment 331 | ; 332 | (define init-env (list (list 333 | (cons 'car car) 334 | (cons 'cdr cdr) 335 | (cons 'cons cons) 336 | (cons 'list list) 337 | (cons 'pair? pair?) 338 | (cons 'null? null?) 339 | (cons 'eq? eq?) 340 | (cons 'eqv? eqv?) 341 | (cons 'equal? equal?) 342 | (cons 'not not) 343 | (cons 'set-car! set-car!) 344 | (cons 'set-cdr! set-cdr!) 345 | (cons 'append append) 346 | (cons 'write primitive-write) 347 | (cons 'pp primitive-pp) 348 | (cons 'display primitive-display) 349 | (cons 'print primitive-print) 350 | (cons 'newline newline) 351 | (cons 'read read) 352 | (cons '+ +) 353 | (cons '- -) 354 | (cons '* *) 355 | (cons '/ /) 356 | (cons '= =) 357 | (cons '> >) 358 | (cons '< <) 359 | (cons 'quotient quotient) 360 | (cons 'remainder remainder) 361 | (cons 'number? number?) 362 | (cons 'boolean? boolean?) 363 | (cons 'string? string?) 364 | (cons 'symbol? symbol?) 365 | (cons 'procedure? primitive-procedure?) 366 | (cons 'assq assq) 367 | (cons 'member member) 368 | (cons 'length length) 369 | (cons 'force force) 370 | (cons 'open-input-file open-input-file) 371 | (cons 'close-input-port close-input-port) 372 | (cons 'eof-object? eof-object?) 373 | 374 | (cons 'map map) 375 | (cons 'scheme-apply scheme-apply) 376 | 377 | (cons 'empty-env empty-env) 378 | (cons 'make-pairs make-pairs) 379 | (cons 'extend extend) 380 | (cons 'can-receive? can-receive?) 381 | (cons 'get get) 382 | (cons 'set-value! set-value!) 383 | (cons 'define-value define-value) 384 | (cons 'search search) 385 | (cons 'copy copy) 386 | (cons 'get-global-env get-global-env) 387 | 388 | (cons 'base-eval base-eval) 389 | (cons 'eval-application eval-application) 390 | (cons 'eval-var eval-var) 391 | (cons 'eval-quote eval-quote) 392 | (cons 'eval-if eval-if) 393 | (cons 'eval-cond eval-cond) 394 | (cons 'eval-define eval-define) 395 | (cons 'eval-set! eval-set!) 396 | (cons 'lambda-tag lambda-tag) 397 | (cons 'eval-lambda eval-lambda) 398 | (cons 'eval-begin eval-begin) 399 | (cons 'eval-let eval-let) 400 | (cons 'eval-let* eval-let*) 401 | (cons 'eval-letrec eval-letrec) 402 | (cons 'eval-EM eval-EM) 403 | (cons 'eval-primitive-EM eval-primitive-EM) 404 | (cons 'eval-exit eval-exit) 405 | (cons 'eval-list eval-list) 406 | (cons 'base-apply base-apply) 407 | (cons 'my-error my-error) 408 | (cons 'eval-load eval-load) 409 | (cons 'eval-and eval-and) 410 | (cons 'eval-or eval-or) 411 | (cons 'delay-tag delay-tag) 412 | (cons 'eval-delay eval-delay) 413 | (cons 'eval-cons-stream eval-cons-stream) 414 | (cons 'eval-map eval-map) 415 | 416 | (cons 'init-env 0) ; to be filled when making a new level 417 | (cons 'init-cont init-cont) 418 | (cons 'run run) 419 | (cons 'primitive-procedures primitive-procedures) 420 | (cons 'old-env old-env) 421 | (cons 'old-cont old-cont) 422 | ))) 423 | (define-value 'init-env init-env init-env) 424 | -------------------------------------------------------------------------------- /stream.scm: -------------------------------------------------------------------------------- 1 | (define-syntax cons-stream 2 | (syntax-rules () 3 | ((cons-stream a b) 4 | (delay (cons a b))))) 5 | 6 | (define stream-car 7 | (lambda (s) 8 | (car (force s)))) 9 | 10 | (define stream-cdr 11 | (lambda (s) 12 | (cdr (force s)))) 13 | 14 | (define head stream-car) 15 | (define tail stream-cdr) 16 | --------------------------------------------------------------------------------