├── boot.scm ├── format.scm ├── .io.livecode.ch ├── install ├── defaults.json ├── run └── _site │ └── index.html ├── scheme.bl ├── bye.bl ├── jump0.bl ├── test.sh ├── docs └── danvy-malmkjaer-blond-primer.pdf ├── jump0_each_meta.bl ├── exit.bl ├── mit.scm ├── nexit.bl ├── jump0_each.bl ├── cwcc.bl ├── cont.bl ├── cwce.bl ├── README.md ├── permute.bl ├── openloop.bl ├── swap.bl ├── no_recursive_instr.bl ├── sessions.scm └── blond.scm /boot.scm: -------------------------------------------------------------------------------- 1 | (blond) 2 | -------------------------------------------------------------------------------- /format.scm: -------------------------------------------------------------------------------- 1 | (load-option 'format) 2 | -------------------------------------------------------------------------------- /.io.livecode.ch/install: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | echo OK -------------------------------------------------------------------------------- /.io.livecode.ch/defaults.json: -------------------------------------------------------------------------------- 1 | { 2 | "language" : "scheme" 3 | } 4 | -------------------------------------------------------------------------------- /scheme.bl: -------------------------------------------------------------------------------- 1 | (load "exit.bl") 2 | (load "cwcc.bl") 3 | (load "cwce.bl") 4 | -------------------------------------------------------------------------------- /bye.bl: -------------------------------------------------------------------------------- 1 | (common-define bye 2 | (delta (e r k) ; List(RExp) * REnv * RCont -> Str 3 | "bye")) 4 | -------------------------------------------------------------------------------- /jump0.bl: -------------------------------------------------------------------------------- 1 | ((delta (e r k) 2 | (common-define re-enter 3 | (lambda () 4 | (k 'ok))))) 5 | -------------------------------------------------------------------------------- /test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mit-scheme --load format.scm --load mit.scm Val_n+1 3 | ((delta (e r k) 4 | (r 'x))))) 5 | -------------------------------------------------------------------------------- /mit.scm: -------------------------------------------------------------------------------- 1 | (define add1 (lambda (n) (+ n 1))) 2 | (define sub1 (lambda (n) (- n 1))) 3 | (define atom? (lambda (x) (not (pair? x)))) 4 | (define (flush-output-port) (flush-output)) 5 | -------------------------------------------------------------------------------- /nexit.bl: -------------------------------------------------------------------------------- 1 | (common-define nexit 2 | (lambda (n) ; Num_m -> Str_m' 3 | (if (<= n 0) 4 | "home" 5 | ((delta (e r k) 6 | (nexit (sub1 (r 'n)))))))) 7 | -------------------------------------------------------------------------------- /.io.livecode.ch/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | cat $2 $1 >out.scm 5 | #mechanics-shell --load format.scm --load mit.scm --load blond.scm Val) -> Val 3 | ((delta (e r k) 4 | (meaning '(f dummy) 5 | (extend-reified-environment '(dummy) (list k) r) 6 | k))))) 7 | -------------------------------------------------------------------------------- /cont.bl: -------------------------------------------------------------------------------- 1 | (common-define jumpify 2 | (lambda (pc) 3 | (lambda (a) 4 | ((delta (e r k) 5 | (meaning' a r (r 'pc))))))) 6 | 7 | (common-define pushify 8 | (lambda (jc) 9 | (lambda (a) 10 | (let ((env (extend-reified-environment' 11 | (dummy) (list a) 12 | (reify-new-environment)))) 13 | (meaning' dummy env jc))))) 14 | -------------------------------------------------------------------------------- /cwce.bl: -------------------------------------------------------------------------------- 1 | (common-define the-environment 2 | (delta (e r k) ; List(RExp) * REnv * RCont -> Val 3 | (meaning 'dummy 4 | (extend-reified-environment '(dummy) (list r) r) 5 | k))) 6 | 7 | (common-define call/ce 8 | (delta (e r k) ; List(RExp) * REnv * RCont -> Val 9 | (meaning (car e) 10 | r 11 | (lambda (f) (meaning '(f r) 12 | (extend-reified-environment '(f r) (list f r) r) 13 | k))))) 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Blond 2 | the reflective tower Blond by Olivier Danvy & Karoline Malmkjær 3 | 4 | ## Getting Started 5 | ```scheme 6 | (load "blond.scm") 7 | (blond) 8 | ``` 9 | 10 | Play in your browser at [io.livecode.ch](http://io.livecode.ch/learn/namin/blond)! 11 | 12 | ## Original Resources from 1988 13 | - [Code](https://www.cs.cmu.edu/Groups/AI/lang/scheme/code/eval/blond/blond.scm) 14 | - [_A Blond Primer_](docs/danvy-malmkjaer-blond-primer.pdf) 15 | - [_Intensions and Extensions in a Reflective Tower_](https://dl.acm.org/doi/pdf/10.1145/62678.62725) 16 | -------------------------------------------------------------------------------- /permute.bl: -------------------------------------------------------------------------------- 1 | (define permute! 2 | (delta (e0 r0 k0) 3 | ((delta (e1 r1 k1) 4 | ((delta (e2 r2 k2) 5 | (let ((R2 (extend-reified-environment' 6 | (R0 K0) 7 | (list ((r2 'r1) 'r0) 8 | ((r2 'r1) 'k0)) 9 | r2)) 10 | (K2 k2)) 11 | (let ((R1 (extend-reified-environment' 12 | (R2 K2) 13 | (list R2 K2) 14 | (r2 'r1))) 15 | (K1 (r2 'k1))) 16 | (meaning' (meaning' (meaning' "done" R0 K0) 17 | R2 K2) 18 | R1 K1))))))))) 19 | -------------------------------------------------------------------------------- /openloop.bl: -------------------------------------------------------------------------------- 1 | (define openloop 2 | (delta (e r k) ; List(RExp) * REnv * RCont -> Val 3 | (case (length e) 4 | ((1) 5 | (meaning (car e) 6 | r 7 | (lambda (level) 8 | (meaning '(meaning "bottom-level" 9 | (reify-new-environment) 10 | (reify-new-continuation level)) 11 | (extend-reified-environment '(level) (list level) r) 12 | k)))) 13 | ((2) (meaning (car e) 14 | r 15 | (lambda (level) 16 | (meaning (cadr e) 17 | r 18 | (lambda (env) 19 | (meaning '(meaning "bottom-level" 20 | (reify-new-environment) 21 | (reify-new-continuation level env)) 22 | (extend-reified-environment '(level env) (list level env) r) 23 | k)))))) 24 | (else (meaning "openloop: arity mismatch" r k))))) 25 | -------------------------------------------------------------------------------- /swap.bl: -------------------------------------------------------------------------------- 1 | (common-define swap! 2 | (lambda (n o) ; Num * Num -> Str 3 | (cond ((or (< n 0) (< o 0)) 4 | "foobar") 5 | ((< n o) 6 | (get-up! n (- o n) '())) 7 | ((> n o) 8 | (get-up! o (- n o) '())) 9 | (else "already done")))) 10 | 11 | (common-define get-up! 12 | (lambda (n o l) ; Num * Num * List(Pair(REnv, RCont)) -> Str 13 | (if (zero? n) 14 | ((delta (e r k) 15 | (got-up! (r 'o) (cons (cons r k) (r 'l)) '()))) 16 | ((delta (e r k) 17 | (get-up! (sub1 (r 'n)) (r 'o) (cons (cons r k) (r 'l)))))))) 18 | 19 | (common-define got-up! 20 | (lambda (o l ll) ; Num * List(Pair(REnv, RCont)) * List(Pair(REnv, RCont)) -> Str 21 | (if (zero? o) 22 | (meaning (list 'got-down! (kwote (cons (car ll) (cdr l))) (kwote (cdr ll))) 23 | (caar l) 24 | (cdar l)) 25 | ((delta (e r k) 26 | (got-up! (sub1 (r 'o)) (r 'l) (cons (cons r k) (r 'll)))))))) 27 | 28 | (common-define kwote 29 | (lambda (x) ; Val -> RExp 30 | (list 'quote x))) 31 | 32 | (common-define got-down! 33 | (lambda (l ll) ; List(Pair(REnv, RCont)) * List(Pair(REnv, RCont)) -> Str 34 | (if (null? ll) 35 | (get-down! l) 36 | (meaning (list 'got-down! (kwote l) (kwote (cdr ll))) (caar ll) (cdar ll))))) 37 | 38 | (common-define get-down! 39 | (lambda (l) ; List(Pair(REnv, RCont)) -> Str 40 | (if (null? l) 41 | "done!" 42 | (meaning (list 'get-down! (kwote (cdr l))) (caar l) (cdar l))))) 43 | 44 | (load "bye.bl") 45 | -------------------------------------------------------------------------------- /no_recursive_instr.bl: -------------------------------------------------------------------------------- 1 | (blond) 2 | 3 | ((delta (e r k) (meaning e r k)) + 1 6) 4 | ;; returns 7 5 | 6 | ((delta 7 | (e r k) 8 | (let ((old-meaning (r 'meaning))) 9 | (old-meaning e r k)) 10 | ) 11 | + 1 6 12 | ) 13 | ;; returns 7 14 | 15 | ((delta 16 | (e r k) 17 | (let ((old-meaning (r 'meaning))) 18 | (begin 19 | (r 'meaning (lambda (e r k) (old-meaning e r k))) 20 | (meaning e r k))) 21 | ) 22 | + 1 6 23 | ) 24 | ;; returns 7 25 | 26 | ((delta 27 | (e r k) 28 | (let ((old-meaning (r 'meaning))) 29 | (let ((count 0)) 30 | (begin 31 | (r 'meaning (lambda (e r k) 32 | (begin 33 | (set! count (+ count 1)) 34 | (old-meaning e r k)))) 35 | (meaning e r (lambda (v) (k count))))))) 36 | + 1 6 37 | ) 38 | ;; returns 0 39 | 40 | ((delta 41 | (e r k) 42 | (let ((old-meaning (r 'meaning))) 43 | (let ((count 0)) 44 | (begin 45 | ((delta (e1 r1 k1) 46 | (begin 47 | (r1 'meaning (lambda (e r k) 48 | (begin 49 | (r1 'count (+ (r1 'count) 1)) 50 | ((r1 'old-meaning) e r k)))) 51 | (k1 'done)))) 52 | (meaning e r (lambda (v) (k count))))))) 53 | + 1 6 54 | ) 55 | ;; returns 1 56 | 57 | ((delta 58 | (e r k) 59 | (let ((old-meaning (r 'meaning))) 60 | (let ((count 0)) 61 | (let ((my-meaning 62 | (lambda (e r k) 63 | (begin 64 | (set! count (+ count 1)) 65 | (old-meaning e r k))))) 66 | (my-meaning e r (lambda (v) (k count))))))) 67 | + 1 6 68 | ) 69 | ;; returns 1 70 | 71 | (common-define old-meaning meaning) 72 | (common-define count 0) 73 | (common-define meaning 74 | (lambda (e r k) 75 | (begin 76 | (set! count (+ count 1)) 77 | (old-meaning e r k)))) 78 | 79 | ((delta (e r k) (meaning e r k)) + 1 6) 80 | ;; returns 7 81 | count 82 | ;; returns 1 83 | -------------------------------------------------------------------------------- /sessions.scm: -------------------------------------------------------------------------------- 1 | (load "blond.scm") 2 | 3 | (blond) 4 | (load "exit.bl") 5 | (exit "good bye") 6 | (exit "farewell!") 7 | (blond-exit) 8 | 9 | (blond) 10 | (add1 (openloop "marvin")) 11 | ((delta (e r k) 41)) 12 | 13 | ((lambda (x) (openloop "foo")) 0) 14 | ((delta (e r k) x)) 15 | 16 | (let ((x 1)) 17 | ((delta (e r k) 18 | (openloop "fox" r)))) 19 | x 20 | 21 | ((delta (e r k) 22 | (meaning (car e) r k)) "hello world") 23 | 24 | (let ((x "hello world")) 25 | ((delta (e r k) 26 | (meaning (car e) r k)) x)) 27 | 28 | (meaning 1 (reify-new-environment) (lambda (x) x)) 29 | 30 | (meaning 1 (reify-new-environment) add1) 31 | 32 | (meaning 'foobarbaz (reify-new-environment) quote) 33 | 34 | (blond-exit) 35 | 36 | (blond) 37 | (define map 38 | (lambda (f l) ; (Val -> Val) * List(Val) -> List(Val) 39 | ((rec self (lambda (l) 40 | (if (null? l) 41 | '() 42 | (cons (f (car l)) (self (cdr l)))))) l))) 43 | (map (lambda (x) x) '(1 2 3)) 44 | (map add1 '(1 2 3)) 45 | (map quote '(1 2 3)) 46 | (map (delta (e r k) e) '(1 2 3)) 47 | 48 | (blond-exit) 49 | 50 | (blond) 51 | ((delta (e r k) (common-define env r))) 52 | env 53 | (env 'x) 54 | (let ((x 'foobar)) 55 | ((delta (e r k) 56 | (common-define env-x r)))) 57 | env-x 58 | (env-x 'x) 59 | (meaning 'x env-x (lambda (x) x)) 60 | (env-x 'x) 61 | (env-x 'x 'foobarbaz) 62 | (env-x 'x) 63 | (meaning '(set! x 'foo) env-x (lambda (x) x)) 64 | (env-x 'x) 65 | 66 | (meaning '(define y x) env-x (lambda (x) x)) 67 | (env-x 'y) 68 | (blond-exit) 69 | 70 | (blond) 71 | ((reify-new-continuation "rock" 72 | (extend-reified-environment '(foo) 73 | '("bar") 74 | (reify-new-environment))) 75 | "bottom") 76 | foo 77 | 78 | ((reify-new-continuation "Multivac") "new-bottom-level") 79 | ((delta (e r k) "bye")) 80 | 81 | (blond-exit) 82 | 83 | (blond) 84 | (load "scheme.bl") 85 | (continuation-mode) 86 | (add1 (call/cc (lambda (k) 3))) 87 | (add1 (call/cc (lambda (k) (k 3)))) 88 | (add1 (call/cc (lambda (k) (sub1 (k 3))))) 89 | (call/cc (lambda (k) (common-define cont-0-6 k))) 90 | 'dummy ; cont-0-6 is bound to the continuation of iteration 6 at level 0 91 | (cont-0-6 "back to 0-6") 92 | (exit "exit from level 0") 93 | (cont-0-6 "back again to 0-6") 94 | (exit "exit again from level 0") 95 | (blond-exit) 96 | 97 | (blond) 98 | (mute-load "scheme.bl") 99 | (switch-continuation-mode) 100 | (add1 (call/cc (lambda (k) 3))) 101 | (add1 (call/cc (lambda (k) (k 3)))) 102 | (add1 (call/cc (lambda (k) (sub1 (k 3))))) 103 | (call/cc (lambda (k) (common-define cont-0-6 k))) 104 | 'dummy ; cont-0-6 is bound to the continuation of iteration 6 at level 0 105 | (cont-0-6 "back to 0-6") 106 | (exit "exit from level 0") 107 | (cont-0-6 "back again to 0-6") 108 | (exit "exit again from level 0") 109 | (exit 3) 110 | (exit 3) 111 | (exit "at last!") 112 | (blond-exit) 113 | 114 | (blond) 115 | (load "nexit.bl") 116 | (nexit 256) 117 | (nexit 64) 118 | (nexit 8) 119 | (nexit 0) 120 | (blond-exit) 121 | 122 | (blond) 123 | (load "swap.bl") 124 | (swap! 2 1) 125 | (bye) 126 | (bye) 127 | (bye) 128 | (bye) 129 | (blond-exit) 130 | 131 | (blond) 132 | (load "permute.bl") 133 | (load "exit.bl") 134 | (permute!) 135 | (exit "bye") 136 | (exit "ibid.") 137 | (exit "again") 138 | (exit "more") 139 | (blond-exit) 140 | 141 | (blond) 142 | (load "swap.bl") 143 | (load "nexit.bl") 144 | (swap! 85 133) 145 | (bye) 146 | (nexit 83) 147 | (bye) 148 | (bye) 149 | (bye) 150 | (nexit 45) 151 | (bye) 152 | (bye) 153 | (nexit 166) 154 | (blond-exit) 155 | 156 | (blond) 157 | (mute-load "scheme.bl") 158 | (mute-load "blond.scm") 159 | (call/ce 160 | (lambda (r) 161 | (openloop "blond" r))) 162 | (blond) 163 | car 164 | '(1 2 3) 165 | (car '(1 2 3)) 166 | (blond-exit) 167 | car 168 | (blond-exit) 169 | -------------------------------------------------------------------------------- /.io.livecode.ch/_site/index.html: -------------------------------------------------------------------------------- 1 | {% extends "base_livecode.html" %} 2 | 3 | {% block title %}The reflective tower Blond{% endblock %} 4 | 5 | {% block content %} 6 | 7 |
8 | (blond) 9 | (load "exit.bl") 10 | (exit "good bye") 11 | (exit "farewell!") 12 | (blond-exit) 13 |
14 | 15 |
16 | (blond) 17 | (add1 (openloop "marvin")) 18 | ((delta (e r k) 41)) 19 | 20 | ((lambda (x) (openloop "foo")) 0) 21 | ((delta (e r k) x)) 22 | 23 | (let ((x 1)) 24 | ((delta (e r k) 25 | (openloop "fox" r)))) 26 | x 27 | 28 | ((delta (e r k) 29 | (meaning (car e) r k)) "hello world") 30 | 31 | (let ((x "hello world")) 32 | ((delta (e r k) 33 | (meaning (car e) r k)) x)) 34 | 35 | (meaning 1 (reify-new-environment) (lambda (x) x)) 36 | 37 | (meaning 1 (reify-new-environment) add1) 38 | 39 | (meaning 'foobarbaz (reify-new-environment) quote) 40 | 41 | (blond-exit) 42 |
43 | 44 |
45 | (blond) 46 | (define map 47 | (lambda (f l) ; (Val -> Val) * List(Val) -> List(Val) 48 | ((rec self (lambda (l) 49 | (if (null? l) 50 | '() 51 | (cons (f (car l)) (self (cdr l)))))) l))) 52 | (map (lambda (x) x) '(1 2 3)) 53 | (map add1 '(1 2 3)) 54 | (map quote '(1 2 3)) 55 | (map (delta (e r k) e) '(1 2 3)) 56 | 57 | (blond-exit) 58 |
59 | 60 |
61 | (blond) 62 | ((delta (e r k) (common-define env r))) 63 | env 64 | (env 'x) 65 | (let ((x 'foobar)) 66 | ((delta (e r k) 67 | (common-define env-x r)))) 68 | env-x 69 | (env-x 'x) 70 | (meaning 'x env-x (lambda (x) x)) 71 | (env-x 'x) 72 | (env-x 'x 'foobarbaz) 73 | (env-x 'x) 74 | (meaning '(set! x 'foo) env-x (lambda (x) x)) 75 | (env-x 'x) 76 | 77 | (meaning '(define y x) env-x (lambda (x) x)) 78 | (env-x 'y) 79 | (blond-exit) 80 |
81 | 82 |
83 | (blond) 84 | ((reify-new-continuation "rock" 85 | (extend-reified-environment '(foo) 86 | '("bar") 87 | (reify-new-environment))) 88 | "bottom") 89 | foo 90 | 91 | ((reify-new-continuation "Multivac") "new-bottom-level") 92 | ((delta (e r k) "bye")) 93 | 94 | (blond-exit) 95 |
96 | 97 |
98 | (blond) 99 | (load "scheme.bl") 100 | (continuation-mode) 101 | (add1 (call/cc (lambda (k) 3))) 102 | (add1 (call/cc (lambda (k) (k 3)))) 103 | (add1 (call/cc (lambda (k) (sub1 (k 3))))) 104 | (call/cc (lambda (k) (common-define cont-0-6 k))) 105 | 'dummy ; cont-0-6 is bound to the continuation of iteration 6 at level 0 106 | (cont-0-6 "back to 0-6") 107 | (exit "exit from level 0") 108 | (cont-0-6 "back again to 0-6") 109 | (exit "exit again from level 0") 110 | (blond-exit) 111 |
112 | 113 |
114 | (blond) 115 | (mute-load "scheme.bl") 116 | (switch-continuation-mode) 117 | (add1 (call/cc (lambda (k) 3))) 118 | (add1 (call/cc (lambda (k) (k 3)))) 119 | (add1 (call/cc (lambda (k) (sub1 (k 3))))) 120 | (call/cc (lambda (k) (common-define cont-0-6 k))) 121 | 'dummy ; cont-0-6 is bound to the continuation of iteration 6 at level 0 122 | (cont-0-6 "back to 0-6") 123 | (exit "exit from level 0") 124 | (cont-0-6 "back again to 0-6") 125 | (exit "exit again from level 0") 126 | (exit 3) 127 | (exit 3) 128 | (exit "at last!") 129 | (blond-exit) 130 |
131 | 132 |
133 | (blond) 134 | (load "nexit.bl") 135 | (nexit 256) 136 | (nexit 64) 137 | (nexit 8) 138 | (nexit 0) 139 | (blond-exit) 140 |
141 | 142 |
143 | (blond) 144 | (load "swap.bl") 145 | (swap! 2 1) 146 | (bye) 147 | (bye) 148 | (bye) 149 | (bye) 150 | (blond-exit) 151 |
152 | 153 |
154 | (blond) 155 | (load "permute.bl") 156 | (load "exit.bl") 157 | (permute!) 158 | (exit "bye") 159 | (exit "ibid.") 160 | (exit "again") 161 | (exit "more") 162 | (blond-exit) 163 |
164 | 165 |
166 | (blond) 167 | (load "swap.bl") 168 | (load "nexit.bl") 169 | (swap! 85 133) 170 | (bye) 171 | (nexit 83) 172 | (bye) 173 | (bye) 174 | (bye) 175 | (nexit 45) 176 | (bye) 177 | (bye) 178 | (nexit 166) 179 | (blond-exit) 180 |
181 | 182 |
183 | (blond) 184 | (mute-load "scheme.bl") 185 | (mute-load "blond.scm") 186 | (call/ce 187 | (lambda (r) 188 | (openloop "blond" r))) 189 | (blond) 190 | car 191 | '(1 2 3) 192 | (car '(1 2 3)) 193 | (blond-exit) 194 | car 195 | (blond-exit) 196 |
197 | 198 |

Playground

199 | 200 |
201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 |
220 | 221 |

Happy Happy Joy Joy!

222 | 223 | {% endblock %} 224 | -------------------------------------------------------------------------------- /blond.scm: -------------------------------------------------------------------------------- 1 | ;;; From mcvax!diku.dk!danvy@uunet.UU.NET Wed Nov 16 20:38:55 1988 2 | ;;; Date: Thu, 6 Oct 88 15:49:55 +0100 3 | ;;; From: mcvax!diku.dk!danvy@uunet.UU.NET (Olivier Danvy) 4 | ;;; To: scheme-librarian@zurich.ai.mit.edu 5 | ;;; Subject: submission 6 | ;;; 7 | ;;; 8 | ;;; Dear librarian, 9 | ;;; 10 | ;;; here is the source code for the Blond reflective tower 11 | ;;; as described in the article "Intensions and Extensions 12 | ;;; in a Reflective Tower", at the LFP'88 conference. 13 | ;;; Would you find it convenient to have the LaTex source 14 | ;;; of the manual (25 pages), too? 15 | ;;; 16 | ;;; Keep in touch. 17 | ;;; 18 | ;;; Kind regards, Olivier 19 | ;;; 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ; blond-88.scm -- commented listing of Blond in -*- Scheme -*- version 0.8 22 | ; 23 | ; 24 | ; This is the non-reflective simulator of a reflective tower described in 25 | ; 26 | ; Intensions and Extensions in a Reflective Tower 27 | ; 28 | ; pp 327-341 of the proceedings of the 29 | ; 1988 ACM Conference on Lisp and Functional Programming 30 | ; 31 | ; 32 | ; Olivier Danvy & Karoline Malmkjaer 33 | ; DIKU -- Computer Science Department 34 | ; University of Copenhagen 35 | ; Universitetsparken 1 36 | ; DK-2100 Copenhagen O 37 | ; Denmark 38 | ; 39 | ; e-mail: danvy@diku.dk 40 | ; karoline@diku.dk 41 | ; from US: mcvax!diku!danvy@uunet.uu.net 42 | ; 43 | ; Phone: (45) 1 39 64 66 and ask 44 | ; ----------------------------------------------------------------------------- 45 | 46 | 47 | ; Copenhagen, January-August 1988 48 | 49 | ; Use: under Scheme, load "blond.scm" 50 | ; then type (blond) 51 | 52 | ; This interpreter is totally meta-circular. 53 | ; It can be loaded in a blond session with 54 | ; (load "blond.scm") 55 | ; and started with 56 | ; (blond) 57 | ; at the price of a certain slowness, 58 | ; but starting a reflective tower orthogonal to the current one. 59 | ; 60 | ; Note: as it stands here, Blond is not perfect, and has already been 61 | ; considerably improved. But it has the advantage to be faithful 62 | ; to the LFP'88 paper and to have an accurate manual. 63 | ; ----------------------------------------------------------------------------- 64 | 65 | 66 | ; Domains: 67 | 68 | ; Denotable values = expressible values = storable values: 69 | ; Val = Num + String + Ide + Pair + 70 | ; Abstraction + Subr + Fsubr + 71 | ; Environment + Continuation + 72 | ; DeltaReifier + GammaReifier 73 | 74 | ; Answers: 75 | ; Ans = Val + {_|_} 76 | 77 | ; Meta-continuations: 78 | ; Meta-Cont = (Env x Cont) x Meta-Cont 79 | 80 | ; Environments and continuations: 81 | ; Env = (Ide* x Val*)* -- lexical extensions, then global, then common 82 | ; Cont = Val x MC -> Ans 83 | 84 | ; Procedures, primitive functions and control structures: 85 | ; Lambda-Abstraction = Val* x Cont x MC -> Ans 86 | ; Subr = Val* -> Val 87 | ; Fsubr = Expr* x Env x Cont x MC 88 | 89 | ; Reified environments and continuations: 90 | ; Environment = (Unit -> Val) + (Ide -> Val) + (Ide x Val -> Val) 91 | ; Continuation = Cont 92 | 93 | ; Reifiers: 94 | ; Delta-Reifier = Val x Val x Val x Env x Cont x MC -> Ans 95 | ; Gamma-Reifier = Val x Val x Val x Cont x MC -> Ans 96 | 97 | ; ----- the core -------------------------------------------------------------- 98 | ; A Blond expression is either a constant (that are left as they are), 99 | ; an identifier (that is looked up) or a pair (that represents a redexe). 100 | 101 | ; Expr * Env * Cont * Meta-Cont -> Val 102 | (define _eval 103 | (lambda (e r k tau) 104 | (cond 105 | ((_constant? e) 106 | (k e tau)) 107 | ((_identifier? e) 108 | (_lookup e r k tau)) 109 | ((pair? e) 110 | (_eval (car e) 111 | r 112 | (lambda (f tau) 113 | (_apply f (cdr e) r k tau)) 114 | tau)) 115 | (else 116 | (_wrong '_eval "unknown form" e))))) 117 | 118 | 119 | ; An identifier is first looked up in the current lexical extension of 120 | ; the environment, then in the global environment of the current level, 121 | ; and lastly in the common environment. 122 | 123 | ; Ide * Env * Cont * Meta-Cont -> Val 124 | (define _lookup 125 | (lambda (i r k tau) 126 | (let ((pos (_index i (caar r)))) 127 | (if (isNatural? pos) 128 | (k (_access (_nth pos (cdar r))) tau) 129 | (if (null? (cdr r)) 130 | (_lookup_common i k tau) 131 | (_lookup i (cdr r) k tau)))))) 132 | 133 | ; Ide * Cont * Meta-Cont -> Val 134 | (define _lookup_common 135 | (lambda (i k tau) 136 | (let ((pos (_index i table-common-identifiers))) 137 | (if (isNatural? pos) 138 | (k (_access (_nth pos table-common-values)) tau) 139 | (_wrong '_lookup_common "unbound identifier" i))))) 140 | 141 | 142 | ; Applying an applicable object dispatches on its injection tag. 143 | 144 | ; Fun * List-of-Expr * Env * Cont * Meta-Cont -> Val 145 | (define _apply 146 | (lambda (fo l r k tau) 147 | (if (_applicable? fo) 148 | (case (_fetch-ftype fo) 149 | ((subr) 150 | (_apply_subr fo l r k tau)) 151 | ((fsubr) 152 | (_apply_fsubr fo l r k tau)) 153 | ((lambda-abstraction) 154 | (_apply_procedure fo l r k tau)) 155 | ((delta-abstraction) 156 | (_apply_delta-reifier fo l r k tau)) 157 | ((gamma-abstraction) 158 | (_apply_gamma-reifier fo l r k tau)) 159 | ((environment) 160 | (_apply_environment fo l r k tau)) 161 | ((continuation) 162 | (_apply_continuation fo l r k tau)) 163 | (else 164 | (_wrong '_apply "unknown functional object" (car fo)))) 165 | (_wrong '_apply "unapplicable form" fo)))) 166 | 167 | 168 | ; Applying a primitive function dispatches on its arity. There are 169 | ; currently nullary, unary, binary, and ternary primitive functions. 170 | 171 | ; Subr * List-of-Expr * Env * Cont * Meta-Cont -> Val 172 | (define _apply_subr 173 | (lambda (f l r k tau) 174 | (if (not (= (length l) (_fetch-arity f))) 175 | (_wrong '_apply_subr "arity mismatch" l) 176 | (case (_fetch-arity f) 177 | ((0) 178 | (k ((_fetch-value f)) tau)) 179 | ((1) 180 | (_eval (car l) r (lambda (a tau) 181 | (k ((_fetch-value f) a) tau)) tau)) 182 | ((2) 183 | (_eval (car l) 184 | r 185 | (lambda (a1 tau) 186 | (_eval (cadr l) 187 | r 188 | (lambda (a2 tau) 189 | (k ((_fetch-value f) a1 a2) tau)) 190 | tau)) 191 | tau)) 192 | ((3) 193 | (_eval (car l) 194 | r 195 | (lambda (a1 tau) 196 | (_eval (cadr l) 197 | r 198 | (lambda (a2 tau) 199 | (_eval (caddr l) 200 | r 201 | (lambda (a3 tau) 202 | (k ((_fetch-value f) 203 | a1 a2 a3) tau)) 204 | tau)) 205 | tau)) 206 | tau)) 207 | (else 208 | (_wrong '_apply_subr "arity" f)))))) 209 | 210 | 211 | ; Before reducing a special form, its arity is checked. 212 | 213 | ; Fsubr * List-of-Expr * Env * Cont * Meta-Cont -> Val 214 | (define _apply_fsubr 215 | (lambda (fv l r k tau) 216 | (if (or (= (length l) (_fetch-arity fv)) 217 | (zero? (_fetch-arity fv))) ; arbitrary number of arguments 218 | ((_fetch-value fv) l r k tau) 219 | (_wrong '_apply_fsubr "arity mismatch" l)))) 220 | 221 | 222 | ; The arity of procedures is also checked: 223 | 224 | ; Lambda-Abstraction * List-of-Expr * Env * Cont * Meta-Cont -> Val 225 | (define _apply_procedure 226 | (lambda (p l r k tau) 227 | (if (not (= (length l) (_fetch-arity p))) 228 | (_wrong '_apply_procedure "arity mismatch" l) 229 | (_evlis l r (lambda (lv tau) 230 | ((_fetch-value p) lv k tau)) tau)))) 231 | 232 | 233 | ; A sequence of expressions is evaluated from left to right: 234 | 235 | ; List-of-Expr * Env * Cont * Meta-Cont -> Val 236 | (define _evlis 237 | (lambda (l r k tau) 238 | (if (null? l) 239 | (k '() tau) 240 | (_eval (car l) 241 | r 242 | (lambda (v tau) 243 | (_evlis (cdr l) 244 | r 245 | (lambda (lv tau) 246 | (k (cons v lv) tau)) 247 | tau)) 248 | tau)))) 249 | 250 | 251 | ; Applying a reified environment gives access to its representation, 252 | ; looks up an identifier, or assigns it, according to the number of arguments. 253 | 254 | ; Reified-Env * List-of-Expr * Env * Cont * Meta-Cont -> Val 255 | (define _apply_environment 256 | (lambda (f l r k tau) 257 | (case (length l) 258 | ((0) 259 | (k (_env-down f) tau)) 260 | ((1) 261 | (_eval (car l) 262 | r 263 | (lambda (i tau) 264 | (if (_identifier? i) 265 | (k (_R_lookup i (_env-down f)) tau) 266 | (_wrong '_apply_environment 267 | "not an identifier" 268 | i))) 269 | tau)) 270 | ((2) 271 | (_eval (car l) 272 | r 273 | (lambda (i tau) 274 | (_eval (cadr l) 275 | r 276 | (lambda (v tau) 277 | (_apply_environment_set! i v f k tau)) 278 | tau)) 279 | tau)) 280 | (else 281 | (_wrong '_apply_environment "arity mismatch" l))))) 282 | 283 | 284 | ; Ide * Reified-Env -> Val 285 | (define _R_lookup 286 | (lambda (i r) 287 | (let ((pos (_index i (caar r)))) 288 | (if (isNatural? pos) 289 | (_access (_nth pos (cdar r))) 290 | (if (null? (cdr r)) 291 | (_R_lookup_common i) 292 | (_R_lookup i (cdr r))))))) 293 | 294 | ; Ide -> Val 295 | (define _R_lookup_common 296 | (lambda (i) 297 | (let ((pos (_index i table-common-identifiers))) 298 | (if (isNatural? pos) 299 | (_access (_nth pos table-common-values)) 300 | '***undefined***)))) 301 | 302 | 303 | ; Ide * Val * Reified-Env * Cont * Meta-Cont -> Val 304 | (define _apply_environment_set! 305 | (lambda (i v f k tau) 306 | (if (_identifier? i) 307 | (let ((location (_L_lookup i (_env-down f)))) 308 | (if (null? location) 309 | (_wrong '_apply_environment "undefined variable" i) 310 | (let ((o (_access location))) 311 | (begin 312 | (_update location v) 313 | (k o tau))))) 314 | (_wrong '_apply_environment "not an identifier" i)))) 315 | 316 | ; Ide * Reified-Env -> Loc 317 | (define _L_lookup 318 | (lambda (i r) 319 | (let ((pos (_index i (caar r)))) 320 | (if (isNatural? pos) 321 | (_nth pos (cdar r)) 322 | (if (null? (cdr r)) 323 | (_L_lookup_common i r) 324 | (_L_lookup i (cdr r))))))) 325 | 326 | ; Ide * Reified-Environment -> Loc 327 | (define _L_lookup_common 328 | (lambda (i r) 329 | (let ((pos (_index i table-common-identifiers))) 330 | (if (isNatural? pos) 331 | (begin 332 | (set-car! (car r) 333 | (cons i (caar r))) 334 | (set-cdr! (car r) 335 | (cons (_access (_nth pos table-common-values)) 336 | (cdar r))) 337 | (cdar r)) 338 | '())))) 339 | 340 | 341 | ; Applying a continuation can be done jumpily or pushily. In the first case, 342 | ; the current continuation is ignored; in the second, the current 343 | ; environment and continuation are pushed onto the meta-continuation. 344 | 345 | ; Reified-Cont * List-of-Expr * Env * Cont * Meta-Cont -> Val 346 | (define _apply_continuation-jumpy 347 | (lambda (c l r k tau) 348 | (if (= (length l) 1) 349 | (_eval (car l) r (_cont-down c) tau) 350 | (_wrong '_apply_continuation-jumpy "arity mismatch" l)))) 351 | 352 | ; Reified-Cont * List-of-Expr * Env * Cont * Meta-Cont -> Val 353 | (define _apply_continuation-pushy 354 | (lambda (c l r k tau) 355 | (if (= (length l) 1) 356 | (_eval (car l) r (_cont-down c) (_meta-push r k tau)) 357 | (_wrong '_apply_continuation-pushy "arity mismatch" l)))) 358 | 359 | ; Hook for the toggle switch-continuation-mode: 360 | (define _apply_continuation _apply_continuation-jumpy) 361 | 362 | 363 | 364 | ; Applying a reifier reifies its arguments, the current environment and 365 | ; the current continuation: 366 | 367 | ; Delta-Reifier * List-of-Expr * Env * Cont * Meta-Cont -> Val 368 | (define _apply_delta-reifier 369 | (lambda (d l r k tau) 370 | ((_untag d) (_exp-up* l) (_env-up r) (_cont-up k) 371 | (_top-env tau) (_top-cont tau) (_meta-pop tau)))) 372 | 373 | 374 | ; Gamma-Reifier * List-of-Expr * Env * Cont * Meta-Cont -> Val 375 | (define _apply_gamma-reifier 376 | (lambda (g l r k tau) 377 | ((_untag g) (_exp-up* l) (_env-up r) (_cont-up k) 378 | (_top-cont tau) (_meta-pop tau)))) 379 | 380 | 381 | ; List-of-Expr -> List-of-Exp 382 | (define _exp-up* 383 | (lambda (l) ; (map copy l) 384 | l)) 385 | 386 | (define _exp-up 387 | (lambda (e) 388 | e)) ; (copy e) 389 | 390 | ; Env -> Reified-Env 391 | (define _env-up 392 | (lambda (r) 393 | (cons 'environment (lambda () r)))) 394 | 395 | ; Cont -> Reified-Cont 396 | (define _cont-up 397 | (lambda (k) 398 | (cons 'continuation k))) 399 | 400 | (define _untag cdr) 401 | 402 | 403 | 404 | ; Reflecting spawns a new level. 405 | 406 | ; List-of-Expr * Env * Cont * Meta-Cont -> Val 407 | (define _meaning 408 | (lambda (l r k tau) 409 | (_eval (car l) 410 | r 411 | (lambda (a1 tau) 412 | (_eval (cadr l) 413 | r 414 | (lambda (a2 tau) 415 | (_eval (caddr l) 416 | r 417 | (lambda (a3 tau) 418 | (_check_and_spawn a1 a2 a3 r k tau)) 419 | tau)) 420 | tau)) 421 | tau))) 422 | 423 | ; Val * Val * Val * Env * Cont * Meta-Cont -> Val 424 | (define _check_and_spawn 425 | (lambda (a1 a2 a3 r k tau) 426 | (cond 427 | ((not (_expressible? a1)) 428 | (_wrong '_meaning "non-expressible value" a1)) 429 | ((not (_ecological? a2)) 430 | (_wrong '_meaning "polluted environment" a2)) 431 | ((not (_continuable? a3)) 432 | (_wrong '_meaning "pitfall" a3)) 433 | (else 434 | (_spawn (_exp-down a1) (_env-down a2) 435 | a3 ; _spawn is going to _cont-down a3 436 | r k tau))))) 437 | 438 | ; Expr -> Bool 439 | (define _expressible? ; safe 440 | (lambda (x) 441 | (or (constant? x) 442 | (_identifier? x) 443 | (and (pair? x) 444 | (_expressible? (car x)) 445 | (or (null? (cdr x)) 446 | (and (pair? (cdr x)) 447 | (_expressible? (cdr x)))))))) 448 | 449 | ; Expr -> Bool 450 | (define _expressible? ; cheaper 451 | (lambda (x) 452 | 'true)) 453 | 454 | ; Reified-Env -> Bool 455 | (define _environment? ; naive: one could build such an "environment" 456 | (lambda (x) ; changing the tag of a reified continuation! 457 | (and (pair? x) ; he would certainly have what he deserves 458 | (equal? (car x) 'environment) 459 | (procedure? (cdr x))))) 460 | 461 | (define _ecological? _environment?) 462 | 463 | ; Expr -> Bool 464 | (define _continuable? 465 | (lambda (x) 466 | (and (_applicable? x) 467 | (case (_fetch-ftype x) 468 | ((subr) 469 | (= (_fetch-arity x) 1)) 470 | ((fsubr) 471 | (= (_fetch-arity x) 1)) 472 | ((lambda-abstraction) 473 | (= (_fetch-arity x) 1)) 474 | ((delta-abstraction gamma-abstraction environment continuation) 475 | #t) 476 | (else 477 | #f))))) 478 | 479 | ; Expr -> Expr 480 | (define _exp-down 481 | (lambda (x) 482 | x)) 483 | 484 | ; Reified-Env -> Env 485 | (define _env-down 486 | (lambda (r) 487 | (_unwrap-env (cdr r)))) 488 | 489 | ; Reified-Env-without-injection-tag -> Env 490 | (define _unwrap-env 491 | (lambda (r) 492 | (r))) 493 | 494 | ; Expr -> Cont 495 | (define _cont-down cdr) 496 | 497 | 498 | 499 | 500 | ; Expr * Env * Cont * Env * Cont * Meta-Cont -> Val 501 | (define _spawn 502 | (lambda (_e _r _k r k tau) 503 | (case (_fetch-ftype _k) 504 | ((subr) 505 | (_eval _e 506 | _r 507 | (lambda (a tau) 508 | (_terminate-level ((_fetch-value _k) a) tau)) 509 | (_meta-push r k tau))) 510 | ((fsubr) ; adventurous 511 | ((_fetch-value _k) 512 | (list _e) _r _terminate-level (_meta-push r k tau))) 513 | ((lambda-abstraction) 514 | (_eval _e 515 | _r 516 | (lambda (a tau) 517 | ((_fetch-value _k) (list a) 518 | (_top-cont tau) 519 | (_meta-pop tau))) 520 | (_meta-push r k tau))) 521 | ((delta-abstraction) 522 | ((_untag d) (_exp-up _e) (_env-up _r) 523 | (_cont-up _terminate-level) 524 | r k tau)) 525 | ((gamma-abstraction) 526 | ((_untag g) (_exp-up _e) (_env-up _r) 527 | (_cont-up _terminate-level) 528 | k tau)) 529 | ((environment) 530 | (_eval _e 531 | _r 532 | (lambda (i tau) 533 | (if (_identifier? i) 534 | (_terminate-level (_R_lookup i 535 | (_env-down _k)) 536 | tau) 537 | (_wrong '_environment 538 | "not an identifier" 539 | i))) 540 | (_meta-push r k tau))) 541 | ((continuation) 542 | (_eval _e _r (_cont-down _k) (_meta-push r k tau)))))) 543 | 544 | 545 | 546 | ; Terminating a level transmits the result to the level above: 547 | 548 | ; Val * Meta-Cont -> Val 549 | (define _terminate-level 550 | (lambda (a tau) 551 | ((_top-cont tau) a (_meta-pop tau)))) 552 | 553 | 554 | ; An applicable object is built out of injection tags and an actual value: 555 | 556 | (define _applicable? 557 | (lambda (x) 558 | (and (pair? x) 559 | (case (car x) 560 | ((subr fsubr lambda-abstraction) 561 | (and (= 3 (length x)) 562 | (number? (cadr x)) 563 | (procedure? (caddr x)))) 564 | ((delta-abstraction gamma-abstraction) 565 | (procedure? (cdr x))) 566 | ((environment continuation) 567 | (procedure? (cdr x))) 568 | (else 569 | #f))))) 570 | 571 | 572 | ; ----- the values in the initial environment --------------------------------- 573 | 574 | ; Evaluating a value designated by quote dereferences it: 575 | (define _quote 576 | (lambda (l r k tau) 577 | (k (car l) tau))) 578 | 579 | 580 | ; As in Scheme, booleans are #t and #f, and in addition, 581 | ; the empty list stands for false, and anything that is not false is true: 582 | (define _if 583 | (lambda (l r k tau) 584 | (_eval (car l) r (lambda (a tau) 585 | (case a 586 | ((#t) 587 | (_eval (cadr l) r k tau)) 588 | ((#f) 589 | (_eval (caddr l) r k tau)) 590 | (else 591 | (if (null? a) 592 | (_eval (caddr l) r k tau) 593 | (_eval (cadr l) r k tau))))) tau))) 594 | 595 | 596 | ; lambda, delta, and gamma-abstractions evaluate to functions and reifiers: 597 | (define _lambda 598 | (lambda (l r k tau) 599 | (k (_inLambda-Abstraction (length (car l)) 600 | (lambda (lv k tau) 601 | (_eval (cadr l) 602 | (_extend_env (car l) lv r) 603 | k 604 | tau))) 605 | tau))) 606 | 607 | (define _inLambda-Abstraction 608 | (lambda (n a) 609 | (list 'lambda-abstraction n a))) 610 | 611 | 612 | (define _delta 613 | (lambda (l r k tau) 614 | (if (not (= (length (car l)) 3)) 615 | (_wrong '_delta "list of formal parameters" (car l)) 616 | (k (_inDelta-Abstraction (lambda (ee rr kk rho kappa tau) 617 | (_eval (cadr l) 618 | (_extend_env (car l) 619 | (list ee rr kk) 620 | rho) 621 | kappa 622 | tau))) 623 | tau)))) 624 | 625 | (define _inDelta-Abstraction 626 | (lambda (a) 627 | (cons 'delta-abstraction a))) 628 | 629 | 630 | (define _gamma 631 | (lambda (l r k stau) 632 | (if (not (= (length (car l)) 3)) 633 | (_wrong '_gamma "list of formal parameters" (car l)) 634 | (k (_inGamma-Abstraction (lambda (ee rr kk kappa tau) 635 | (_eval (cadr l) 636 | (_extend_env (car l) 637 | (list ee rr kk) 638 | (_top-env stau)) 639 | kappa 640 | tau))) 641 | stau)))) 642 | 643 | (define _inGamma-Abstraction 644 | (lambda (a) 645 | (cons 'gamma-abstraction a))) 646 | 647 | 648 | 649 | ; A common definition affects the common environment: 650 | (define _common-define 651 | (lambda (l r k tau) 652 | (if (not (_identifier? (car l))) 653 | (_wrong '_common-define "undefinable" (car l)) 654 | (_eval 655 | (cadr l) 656 | r 657 | (lambda (a tau) 658 | (let ((pos (_index (car l) table-common-identifiers))) 659 | (if (isNatural? pos) 660 | (begin 661 | (_update (_nth pos table-common-values) a) 662 | (k (car l) tau)) 663 | (begin 664 | (set! table-common-identifiers 665 | (cons (car l) table-common-identifiers)) 666 | (set! table-common-values 667 | (cons a table-common-values)) 668 | (k (car l) tau))))) tau)))) 669 | 670 | 671 | 672 | ; A definition affects the global environment of the current level. 673 | (define _define 674 | (lambda (l r k tau) 675 | (if (not (_identifier? (car l))) 676 | (_wrong '_define "undefinable" (car l)) 677 | (_eval 678 | (cadr l) 679 | r 680 | (lambda (a tau) 681 | (let* ((global-env (car (last-pair r))) 682 | (pos (_index (car l) (car global-env)))) 683 | (if (isNatural? pos) 684 | (begin 685 | (_update (_nth pos (cdr global-env)) a) 686 | (k (car l) tau)) 687 | (begin 688 | (set-car! global-env 689 | (cons (car l) (car global-env))) 690 | (set-cdr! global-env 691 | (cons a (cdr global-env))) 692 | (k (car l) tau))))) tau)))) 693 | 694 | 695 | 696 | ; An assignment affects the representation of the environment. Assigning 697 | ; a common identifier shadows it at the current level. 698 | (define _set! 699 | (lambda (l r k tau) 700 | (if (not (_identifier? (car l))) 701 | (_wrong '_set! "undefinable" (car l)) 702 | (_eval (cadr l) r (lambda (a tau) 703 | (_L_set! (car l) a r k tau)) tau)))) 704 | 705 | (define _L_set! 706 | (lambda (i v r k tau) 707 | (let ((pos (_index i (caar r)))) 708 | (if (isNatural? pos) 709 | (let* ((location (_nth pos (cdar r))) 710 | (previous-value (_access location))) 711 | (begin 712 | (_update location v) 713 | (k previous-value tau))) 714 | (if (null? (cdr r)) 715 | (let ((pos (_index i table-common-identifiers))) 716 | (if (isNatural? pos) 717 | (begin 718 | (set-car! (car r) (cons i (caar r))) 719 | (set-cdr! (car r) (cons v (cdar r))) 720 | (k (_access (_nth pos table-common-values)) 721 | tau)) 722 | (_wrong '_L_set! "undefined variable" i))) 723 | (_L_set! i v (cdr r) k tau)))))) 724 | 725 | 726 | 727 | ; The extensional if, that evaluates all its arguments: 728 | (define _ef 729 | (lambda (p at af) 730 | (case p 731 | ((#t) 732 | at) 733 | ((#f) 734 | af) 735 | (else 736 | (if (null? p) af at))))) 737 | 738 | 739 | ; The case statement: 740 | (define _case 741 | (lambda (l r k tau) 742 | (_eval (car l) r (lambda (a tau) 743 | (_case_loop a (cdr l) r k tau)) tau))) 744 | 745 | (define _case_loop 746 | (lambda (a l r k tau) 747 | (if (null? l) 748 | (_wrong '_case_loop "unmatched" a) 749 | (if (equal? (caar l) 'else) 750 | (_eval (cadr (car l)) r k tau) 751 | (if ((if (pair? (caar l)) member equal?) a (caar l)) 752 | (_eval (cadr (car l)) r k tau) 753 | (_case_loop a (cdr l) r k tau)))))) 754 | 755 | 756 | ; The conjunctive expression: 757 | (define _and 758 | (lambda (l r k tau) 759 | (if (null? l) 760 | (k #t tau) 761 | (_and_loop l r k tau)))) 762 | 763 | (define _and_loop 764 | (lambda (l r k tau) 765 | (if (null? (cdr l)) 766 | (_eval (car l) r k tau) 767 | (_eval (car l) r (lambda (a tau) 768 | (if (or (null? a) (equal? a #f)) 769 | (k #f tau) 770 | (_and_loop (cdr l) r k tau))) tau)))) 771 | 772 | 773 | ; The disjunctive expression: 774 | (define _or 775 | (lambda (l r k tau) 776 | (if (null? l) 777 | (k #f tau) 778 | (_or_loop l r k tau)))) 779 | 780 | (define _or_loop 781 | (lambda (l r k tau) 782 | (if (null? (cdr l)) 783 | (_eval (car l) r k tau) 784 | (_eval (car l) r (lambda (a tau) 785 | (if (or (null? a) (equal? a #f)) 786 | (_or_loop (cdr l) r k tau) 787 | (k a tau))) tau)))) 788 | 789 | 790 | ; The sequence statement: 791 | (define _begin 792 | (lambda (l r k tau) 793 | (if (null? (cdr l)) 794 | (_eval (car l) r k tau) 795 | (_eval (car l) r (lambda (a tau) 796 | (_begin (cdr l) r k tau)) tau)))) 797 | 798 | 799 | ; Reading is done either from the implicit input stream 800 | ; or from an explicit port: 801 | (define _read 802 | (lambda (l r k tau) 803 | (if (null? l) 804 | (k (read) tau) 805 | (if (null? (cdr l)) 806 | (_eval (car l) 807 | r 808 | (lambda (port tau) 809 | (k (read port) tau)) 810 | tau) 811 | (_wrong '_read "arity mismatch" l))))) 812 | 813 | 814 | ; Loading a file redirects the input stream: 815 | (define _load 816 | (lambda (l r k tau) 817 | (_eval (car l) 818 | r 819 | (lambda (file tau) 820 | (_load_loop file (open-input-file file) r k tau)) 821 | tau))) 822 | 823 | (define _load_loop 824 | (lambda (file port r k tau) 825 | (let ((it (read port))) 826 | (if (eof-object? it) 827 | (begin 828 | (newline) 829 | (close-input-port port) 830 | (k file tau)) 831 | (let ((a (_eval it r (lambda (a tau) (list 'okay a tau)) tau))) 832 | (if (equal? (car a) 'okay) 833 | (begin 834 | (display (cadr a)) (display " ") (flush-output-port) 835 | (_load_loop file port r k tau)) 836 | (begin 837 | (close-input-port port) 838 | a))))))) 839 | 840 | 841 | ; A file can be loaded without displaying the results of the evaluations: 842 | (define _mute-load 843 | (lambda (l r k tau) 844 | (_eval (car l) 845 | r 846 | (lambda (file tau) 847 | (_mute-load_loop file (open-input-file file) r k tau)) 848 | tau))) 849 | 850 | (define _mute-load_loop 851 | (lambda (file port r k tau) 852 | (let ((it (read port))) 853 | (if (eof-object? it) 854 | (begin 855 | (close-input-port port) 856 | (k file tau)) 857 | (let ((a (_eval it r (lambda (a tau) (list 'okay a tau)) tau))) 858 | (if (equal? (car a) 'okay) 859 | (_mute-load_loop file port r k tau) 860 | (begin 861 | (close-input-port port) 862 | a))))))) 863 | 864 | 865 | 866 | ; A new interactive level can be spawned: 867 | (define _openloop 868 | (lambda (l r k tau) 869 | (case (length l) 870 | ((1) 871 | (_eval (car l) 872 | r 873 | (lambda (new-level tau) 874 | ((_generate_toplevel-continuation 875 | new-level (make-initial-environment)) 876 | blond-banner 877 | (_meta-push r k tau))) 878 | tau)) 879 | ((2) 880 | (_eval (car l) 881 | r 882 | (lambda (new-level tau) 883 | (_eval (cadr l) 884 | r 885 | (lambda (new-env tau) 886 | (if (_environment? new-env) 887 | ((_generate_toplevel-continuation 888 | new-level 889 | (_env-down new-env)) 890 | blond-banner 891 | (_meta-push r k tau)) 892 | (_wrong '_openloop 893 | "not a reified environment" 894 | new-env))) 895 | tau)) 896 | tau)) 897 | (else 898 | (_wrong '_openloop "wrong arity" l))))) 899 | 900 | 901 | ; Extending a reified environment needs reflecting it & reifying its extension: 902 | (define _access 903 | car) 904 | 905 | (define _update 906 | set-car!) 907 | 908 | 909 | (define _extend-reified-environment 910 | (lambda (l r k tau) 911 | (_eval (car l) 912 | r 913 | (lambda (a1 tau) 914 | (_eval (cadr l) 915 | r 916 | (lambda (a2 tau) 917 | (_eval (caddr l) 918 | r 919 | (lambda (a3 tau) 920 | (_extend a1 a2 a3 k tau)) 921 | tau)) 922 | tau)) 923 | tau))) 924 | 925 | 926 | (define _extend 927 | (lambda (li lv r k tau) 928 | (cond 929 | ((not (pair? li)) 930 | (_wrong '_extend-reified-environment 931 | "not a list of identifiers" 932 | li)) 933 | ((not (pair? lv)) 934 | (_wrong '_extend-reified-environment 935 | "not a list of values" 936 | li)) 937 | ((not (= (length li) (length lv))) 938 | (_wrong '_extend-reified-environment 939 | "lists mismatch" 940 | (list li lv))) 941 | ((not (_environment? r)) 942 | (_wrong '_extend-reified-environment 943 | "not a reified environment" 944 | r)) 945 | (else 946 | (k (_env-up (_extend_env li lv (_env-down r))) tau))))) 947 | 948 | 949 | 950 | ; The following describes the usual block structures let and letrec. 951 | ; A recursive binding is achieved by side-effect rather than by a fixed point. 952 | (define _let ; assumes a well-formed let construction 953 | (lambda (l r k tau) 954 | (if (null? (car l)) 955 | (_eval (cadr l) r k tau) 956 | (_let_evlis (car l) 957 | r 958 | (lambda (lv tau) 959 | (_eval (cadr l) 960 | (_extend_env (_let_idlis (car l)) lv r) 961 | k 962 | tau)) 963 | tau)))) 964 | 965 | (define _let_evlis 966 | (lambda (h r k tau) 967 | (_eval (cadr (car h)) 968 | r 969 | (lambda (v tau) 970 | (if (null? (cdr h)) 971 | (k (list v) tau) 972 | (_let_evlis (cdr h) 973 | r 974 | (lambda (lv tau) 975 | (k (cons v lv) tau)) 976 | tau))) 977 | tau))) 978 | 979 | (define _let_idlis 980 | (lambda (h) ; (map car h) 981 | (if (null? h) 982 | '() 983 | (cons (caar h) (_let_idlis (cdr h)))))) 984 | 985 | 986 | (define _letrec ; assumes a well-formed letrec construction 987 | (lambda (l r k tau) 988 | (if (null? (car l)) 989 | (_eval (cadr l) r k tau) 990 | (let ((r (_extend_env (_let_idlis (car l)) '() r))) 991 | (_let_evlis (car l) 992 | r 993 | (lambda (lv tau) 994 | (begin 995 | (set-cdr! (car r) lv) 996 | (_eval (cadr l) r k tau))) 997 | tau))))) 998 | 999 | 1000 | (define _rec ; assumes a well-formed rec construction 1001 | (lambda (l r k tau) 1002 | (let ((r (_extend_env (list (car l)) '() r))) 1003 | (_eval (cadr l) r (lambda (a tau) 1004 | (begin 1005 | (set-cdr! (car r) (list a)) 1006 | (k a tau))) tau)))) 1007 | 1008 | 1009 | (define _let* ; assumes a well-formed let* construction 1010 | (lambda (l r k tau) 1011 | (_let*_evlis (car l) (cadr l) r k tau))) 1012 | 1013 | (define _let*_evlis 1014 | (lambda (h b r k tau) 1015 | (if (null? h) 1016 | (_eval b r k tau) 1017 | (_eval (cadr (car h)) 1018 | r 1019 | (lambda (a tau) 1020 | (_let*_evlis (cdr h) 1021 | b 1022 | (_extend_env (list (caar h)) (list a) r) 1023 | k 1024 | tau)) 1025 | tau)))) 1026 | 1027 | 1028 | 1029 | ; Blond provides the usual conditional cond: 1030 | (define _cond 1031 | (lambda (l r k tau) 1032 | (if (null? l) 1033 | (k "unmatched-cond" tau) 1034 | (if (equal? (caar l) 'else) 1035 | (_eval (cadr (car l)) r k tau) 1036 | (_eval (caar l) 1037 | r 1038 | (lambda (a tau) 1039 | (if (or (equal? a #f) (null? a)) 1040 | (_cond (cdr l) r k tau) 1041 | (_eval (cadr (car l)) r k tau))) 1042 | tau))))) 1043 | 1044 | 1045 | 1046 | ; Both a reified instance of the initial environment and a reified 1047 | ; instance of a bottom level loop continuation are available: 1048 | (define _reify-new-environment 1049 | (lambda () 1050 | (_env-up (make-initial-environment)))) 1051 | 1052 | 1053 | (define _reify-new-continuation 1054 | (lambda (l r k tau) 1055 | (case (length l) 1056 | ((1) 1057 | (_eval (car l) 1058 | r 1059 | (lambda (level tau) 1060 | (k (_cont-up (_generate_toplevel-continuation 1061 | level 1062 | (make-initial-environment))) tau)) 1063 | tau)) 1064 | ((2) 1065 | (_eval (car l) 1066 | r 1067 | (lambda (level tau) 1068 | (_eval (cadr l) 1069 | r 1070 | (lambda (env tau) 1071 | (if (_environment? env) 1072 | (k (_cont-up 1073 | (_generate_toplevel-continuation 1074 | level (_env-down env))) 1075 | tau) 1076 | (_wrong '_reify-new-continuation 1077 | "not a reified environment" 1078 | env))) 1079 | tau)) 1080 | tau)) 1081 | (else 1082 | (_wrong '_reify-new-continuation "arity mismatch" l))))) 1083 | 1084 | 1085 | ; Continuations can be applied in a pushy or in a jumpy mode: 1086 | (define _continuation-mode 1087 | (lambda () 1088 | (if (eq? _apply_continuation _apply_continuation-jumpy) 1089 | 'jumpy 1090 | 'pushy))) 1091 | 1092 | 1093 | (define _switch-continuation-mode 1094 | (lambda () 1095 | (if (eq? _apply_continuation _apply_continuation-jumpy) 1096 | (begin 1097 | (set! _apply_continuation _apply_continuation-pushy) 1098 | 'pushy) 1099 | (begin 1100 | (set! _apply_continuation _apply_continuation-jumpy) 1101 | 'jumpy)))) 1102 | 1103 | 1104 | ; Ending a session ignores the current continuation and meta-continuation: 1105 | (define _blond-exit 1106 | (lambda (l r k tau) 1107 | "farvel!")) 1108 | 1109 | 1110 | 1111 | ; ----- the initial environment ----------------------------------------------- 1112 | 1113 | (define table-common-identifiers 1114 | '(nil 1115 | car cdr 1116 | caar cadr 1117 | cdar cddr 1118 | caddr cdddr 1119 | last-pair 1120 | null? atom? pair? 1121 | number? string? symbol? 1122 | zero? add1 sub1 1123 | + - * 1124 | < <= > >= 1125 | cons equal? 1126 | = boolean? 1127 | negative? positive? 1128 | procedure? 1129 | quote 1130 | lambda 1131 | delta meaning gamma 1132 | if ef 1133 | common-define define 1134 | set! 1135 | case 1136 | and or 1137 | list 1138 | set-car! set-cdr! 1139 | begin 1140 | display print 1141 | pretty-print newline 1142 | not length 1143 | load mute-load read 1144 | open-input-file eof-object? 1145 | close-input-port 1146 | flush-output-port 1147 | openloop 1148 | extend-reified-environment 1149 | let letrec 1150 | rec let* 1151 | cond 1152 | blond-exit 1153 | reify-new-environment 1154 | reify-new-continuation 1155 | continuation-mode 1156 | switch-continuation-mode 1157 | )) 1158 | 1159 | (define _inSubr 1160 | (lambda (arity function-value) 1161 | (list 'subr arity function-value))) 1162 | 1163 | (define _inFsubr 1164 | (lambda (arity function-value) 1165 | (list 'fsubr arity function-value))) 1166 | 1167 | 1168 | (define table-common-values 1169 | (list '() 1170 | (_inSubr 1 car) (_inSubr 1 cdr) 1171 | (_inSubr 1 caar) (_inSubr 1 cadr) 1172 | (_inSubr 1 cdar) (_inSubr 1 cddr) 1173 | (_inSubr 1 caddr) (_inSubr 1 cdddr) 1174 | (_inSubr 1 last-pair) 1175 | (_inSubr 1 null?) (_inSubr 1 atom?) (_inSubr 1 pair?) 1176 | (_inSubr 1 number?) (_inSubr 1 string?) (_inSubr 1 symbol?) 1177 | (_inSubr 1 zero?) (_inSubr 1 add1) (_inSubr 1 sub1) 1178 | (_inSubr 2 +) (_inSubr 2 -) (_inSubr 2 *) 1179 | (_inSubr 2 <) (_inSubr 2 <=) (_inSubr 2 >) (_inSubr 2 >=) 1180 | (_inSubr 2 cons) (_inSubr 2 equal?) 1181 | (_inSubr 2 =) (_inSubr 1 boolean?) 1182 | (_inSubr 1 negative?) (_inSubr 1 positive?) 1183 | (_inSubr 1 _applicable?) 1184 | (_inFsubr 1 _quote) 1185 | (_inFsubr 2 _lambda) 1186 | (_inFsubr 2 _delta) (_inFsubr 3 _meaning) (_inFsubr 2 _gamma) 1187 | (_inFsubr 3 _if) (_inSubr 3 _ef) 1188 | (_inFsubr 2 _common-define) (_inFsubr 2 _define) 1189 | (_inFsubr 2 _set!) 1190 | (_inFsubr 0 _case) 1191 | (_inFsubr 0 _and) (_inFsubr 0 _or) 1192 | (_inFsubr 0 _evlis) 1193 | (_inSubr 2 set-car!) (_inSubr 2 set-cdr!) 1194 | (_inFsubr 0 _begin) 1195 | (_inSubr 1 display) (_inSubr 1 pretty-print) 1196 | (_inSubr 1 pretty-print) (_inSubr 0 newline) 1197 | (_inSubr 1 not) (_inSubr 1 length) 1198 | (_inFsubr 1 _load) (_inFsubr 1 _mute-load) (_inFsubr 0 _read) 1199 | (_inSubr 1 open-input-file) (_inSubr 1 eof-object?) 1200 | (_inSubr 1 close-input-port) 1201 | (_inSubr 0 flush-output-port) 1202 | (_inFsubr 0 _openloop) 1203 | (_inFsubr 3 _extend-reified-environment) 1204 | (_inFsubr 2 _let) (_inFsubr 2 _letrec) 1205 | (_inFsubr 2 _rec) (_inFsubr 2 _let*) 1206 | (_inFsubr 0 _cond) 1207 | (_inFsubr 0 _blond-exit) 1208 | (_inSubr 0 _reify-new-environment) 1209 | (_inFsubr 0 _reify-new-continuation) 1210 | (_inSubr 0 _continuation-mode) 1211 | (_inSubr 0 _switch-continuation-mode) 1212 | )) 1213 | 1214 | 1215 | 1216 | ; Miscalleneous: 1217 | (define _wrong 1218 | list) 1219 | 1220 | (define _constant? 1221 | (lambda (x) 1222 | (or (null? x) 1223 | (number? x) 1224 | (string? x) 1225 | (boolean? x)))) 1226 | 1227 | (define _identifier? 1228 | symbol?) 1229 | 1230 | (define _index 1231 | (lambda (i l) 1232 | (_index_loop i 0 l))) 1233 | 1234 | (define _index_loop 1235 | (lambda (i n l) 1236 | (if (null? l) 1237 | -1 1238 | (if (equal? i (car l)) 1239 | n 1240 | (_index_loop i (add1 n) (cdr l)))))) 1241 | 1242 | (define isNatural? 1243 | (lambda (n) 1244 | (>= n 0))) 1245 | 1246 | (define _nth 1247 | (lambda (n l) 1248 | (if (= n 0) 1249 | l 1250 | (_nth (sub1 n) (cdr l))))) 1251 | 1252 | (define _fetch-ftype car) 1253 | (define _fetch-arity cadr) 1254 | (define _fetch-value caddr) 1255 | 1256 | ; Basic lexical environment extension: 1257 | (define _extend_env 1258 | (lambda (par l env) 1259 | (cons (cons par l) env))) 1260 | 1261 | 1262 | 1263 | ; ----- how Blond hangs together ---------------------------------------------- 1264 | 1265 | ; The starting point: 1266 | (define blond 1267 | (lambda () 1268 | ((_generate_toplevel-continuation initial-level 1269 | (make-initial-environment)) 1270 | blond-banner (initial-meta-continuation initial-level)))) 1271 | 1272 | ; The initial level and how to manifest a level above it: 1273 | (define initial-level 0) 1274 | (define level-above add1) 1275 | 1276 | ; The generation of an empty global environment: 1277 | (define make-initial-environment 1278 | (lambda () 1279 | (_extend_env '() '() '()))) 1280 | 1281 | 1282 | ; Some fantasy: 1283 | (define blond-banner ; cf. Full Metal Jacket, Stanley Kubrick (1987) 1284 | "Is it John McCarthy or is it me?") 1285 | (define blond-banner ; cf. Brazil, Terry Gyndham (1985) 1286 | "It's okay, I don't like you either.") 1287 | (define blond-banner ; "til tjeneste" means "at your service" 1288 | "til tjeneste") ; it is an old-fashioned formula in Danish 1289 | (define blond-banner 1290 | "started up") 1291 | (define blond-banner ; cf. 3-Lisp 1292 | "[Thud.]") 1293 | (define blond-banner 1294 | "toplevel") 1295 | (define blond-banner 1296 | "blond") 1297 | (define blond-banner 1298 | "-*-") 1299 | (define blond-banner 1300 | "Blond is winning again") 1301 | (define blond-banner ; a la Brown 1302 | "starting-up") 1303 | (define blond-banner 1304 | "bottom-level") 1305 | 1306 | 1307 | ; A self-generating initial meta-continuation: 1308 | (define initial-meta-continuation 1309 | (lambda (level) 1310 | (let ((an-initial-environment (make-initial-environment))) 1311 | (lambda (selector) 1312 | (case selector 1313 | ((env) 1314 | an-initial-environment) 1315 | ((cont) 1316 | (_generate_toplevel-continuation 1317 | (level-above level) 1318 | an-initial-environment)) 1319 | ((meta-continuation) 1320 | (initial-meta-continuation (level-above level))) 1321 | (else 1322 | (_error foobarbaz))))))) 1323 | 1324 | 1325 | ; How to get the top-most environment: 1326 | (define _top-env 1327 | (lambda (meta-continuation) 1328 | (meta-continuation 'env))) 1329 | 1330 | ; How to get the top-most continuation: 1331 | (define _top-cont 1332 | (lambda (meta-continuation) 1333 | (meta-continuation 'cont))) 1334 | 1335 | ; How to get the next meta-continuation: 1336 | (define _meta-pop 1337 | (lambda (meta-continuation) 1338 | (meta-continuation 'meta-continuation))) 1339 | 1340 | ; How to get a new meta-continuation: 1341 | (define _meta-push 1342 | (lambda (r k tau) 1343 | (lambda (selector) 1344 | (case selector 1345 | ((env) r) 1346 | ((cont) k) 1347 | ((meta-continuation) tau) 1348 | (else (_error foobarbaz)))))) 1349 | 1350 | 1351 | ; Generation of a new top-level loop: 1352 | (define _generate_toplevel-continuation 1353 | (lambda (my-level my-environment) 1354 | (letrec ((elementary-loop 1355 | (lambda (iteration) 1356 | (lambda (val meta-continuation) 1357 | (begin 1358 | (_print my-level iteration val) 1359 | (_eval (read) 1360 | my-environment 1361 | (elementary-loop 1362 | (next-iteration iteration)) 1363 | meta-continuation)))))) 1364 | (elementary-loop first-iteration)))) 1365 | 1366 | ; The first iteration and how to manifest the following ones: 1367 | (define first-iteration 0) 1368 | (define next-iteration add1) 1369 | 1370 | 1371 | 1372 | ; A display mechanism for the prompts: 1373 | (define _print 1374 | (lambda (l i v) 1375 | (begin 1376 | (display l) 1377 | (display "-") 1378 | (display i) 1379 | (display ": ") 1380 | (pretty-print v) 1381 | ; (newline) ; in the case it was just (display v) 1382 | (display l) 1383 | (display "-") 1384 | (display (next-iteration i)) 1385 | (display "> ") 1386 | (flush-output-port)))) 1387 | 1388 | ; ----- end of the file ------------------------------------------------------- 1389 | 1390 | 1391 | --------------------------------------------------------------------------------