├── LICENSE
├── README.md
├── examples
    ├── amb.scm
    ├── dynamic-wind-example.scm
    ├── fib90.scm
    ├── nqueens.scm
    └── yin-yang-puzzle.scm
├── scm.scm
└── tower
    ├── scm-scm-scm.scm
    └── scm-scm.scm


/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2019 SUZUKI Hisao
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining a
 4 | copy of this software and associated documentation files (the "Software"),
 5 | to deal in the Software without restriction, including without limitation
 6 | the rights to use, copy, modify, merge, publish, distribute, sublicense,
 7 | and/or sell copies of the Software, and to permit persons to whom the
 8 | Software is furnished to do so, subject to the following conditions:
 9 | 
10 | The above copyright notice and this permission notice shall be included in
11 | all copies or substantial portions of the Software.
12 | 
13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
16 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
19 | DEALINGS IN THE SOFTWARE.
20 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # A Meta-circular Little Scheme
  2 | 
  3 | This is a meta-circular interpreter of a subset of Scheme, inspired by
  4 | [Zick Standard Lisp](https://github.com/zick/ZickStandardLisp).
  5 | 
  6 | It implements the same language as
  7 | 
  8 | - [little-scheme-in-crystal](https://github.com/nukata/little-scheme-in-crystal)
  9 | - [little-scheme-in-cs](https://github.com/nukata/little-scheme-in-cs)
 10 | - [little-scheme-in-dart](https://github.com/nukata/little-scheme-in-dart)
 11 | - [little-scheme-in-go](https://github.com/nukata/little-scheme-in-go)
 12 | - [little-scheme-in-java](https://github.com/nukata/little-scheme-in-java)
 13 | - [little-scheme-in-kotlin](https://github.com/nukata/little-scheme-in-kotlin)
 14 | - [little-scheme-in-lisp](https://github.com/nukata/little-scheme-in-lisp)
 15 | - [little-scheme-in-php](https://github.com/nukata/little-scheme-in-php)
 16 | - [little-scheme-in-python](https://github.com/nukata/little-scheme-in-python)
 17 | - [little-scheme-in-ruby](https://github.com/nukata/little-scheme-in-ruby)
 18 | - [little-scheme-in-typescript](https://github.com/nukata/little-scheme-in-typescript)
 19 | 
 20 | and runs on them.
 21 | It also runs on other Schemes such as
 22 | [guile](https://www.gnu.org/software/guile/) or any R5RS Schemes.
 23 | 
 24 | 
 25 | 
 26 | ## How to use
 27 | 
 28 | Run `scm.scm` on another Scheme.
 29 | The following example uses [little-scheme-in-go](https://github.com/nukata/little-scheme-in-go).
 30 | 
 31 | ```
 32 | $ little-scheme-in-go scm.scm
 33 | (+ 5 6)
 34 | => 11
 35 | (cons 'a (cons 'b 'c))
 36 | => (a b . c)
 37 | (list
 38 | 1
 39 | 2
 40 | 3
 41 | )
 42 | => (1 2 3)
 43 | +
 44 | => ($Intrinsic . #<(x):((+ (fst x) (snd x))):#<GlobalEnv>>)
 45 | (globals)
 46 | => (globals error number? = < * - + apply call/cc symbol? eof-object? read newline display list not 
 47 | null? pair? eq? cons cdr car)
 48 | ```
 49 | 
 50 | Press EOF (e.g. Control-D) to exit the session.
 51 | 
 52 | 
 53 | <a name="language"></a>
 54 | ## The implemented language
 55 | 
 56 | ### Expression types
 57 | 
 58 | - _v_  [variable reference]
 59 | 
 60 | - (_e0_ _e1_...)  [procedure call]
 61 | 
 62 | - (`quote` _e_)  [`'`_e_ will be transformed into (`quote` _e_) when `read`]
 63 | 
 64 | - (`if` _e1_ _e2_ _e3_)  
 65 |   (`if` _e1_ _e2_)
 66 | 
 67 | - (`begin` _e_...)
 68 | 
 69 | - (`lambda` (_v_...) _e_...)
 70 | 
 71 | - (`set!` _v_ _e_)
 72 | 
 73 | - (`define` _v_ _e_)
 74 | 
 75 | For simplicity, this Scheme treats (`define` _v_ _e_) as an expression type.
 76 | 
 77 | 
 78 | ### Built-in procedures
 79 | 
 80 | |                   |                          |                 |
 81 | |:------------------|:-------------------------|:----------------|
 82 | | (`car` _lst_)     | (`display` _x_)          | (`+` _n1_ _n2_) |
 83 | | (`cdr` _lst_)     | (`newline`)              | (`-` _n1_ _n2_) |
 84 | | (`cons` _x_ _y_)  | (`read`)                 | (`*` _n1_ _n2_) |
 85 | | (`eq?` _x_ _y_)   | (`eof-object?` _x_)      | (`<` _n1_ _n2_) |
 86 | | (`pair?` _x_)     | (`symbol?` _x_)          | (`=` _n1_ _n2_) |
 87 | | (`null?` _x_)     | (`call/cc` _fun_)        | (`number?` _x_) |
 88 | | (`not` _x_)       | (`apply` _fun_ _arg_)    | (`globals`)     |
 89 | | (`list` _x_ ...)  | (`error` _reason_ _arg_) |                 |
 90 | 
 91 | - `(error` _reason_ _arg_`)` displays `Error:` _reason_`:` _arg_ and
 92 |   goes back to the top level.
 93 |   It is based on [SRFI-23](https://srfi.schemers.org/srfi-23/srfi-23.html).
 94 | 
 95 | - `(globals)` returns a list of keys of the global environment.
 96 |   It is not in the standard.
 97 | 
 98 | See [`Global-Env`](scm.scm#L50-L81)
 99 | in `scm.scm` for the implementation of the procedures
100 | except `call/cc` and `apply`.  
101 | `call/cc` and `apply` are implemented particularly at 
102 | [`apply-fun`](scm.scm#L133-L157) in `scm.scm`.
103 | 
104 | 
105 | <a name="examples"></a>
106 | ## Examples
107 | 
108 | There are five files under the `examples` folder:
109 | 
110 | - [`fib90.scm`](examples/fib90.scm)
111 |   calculates Fibonacci for 90 tail-recursively.
112 | 
113 | - [`nqueens.scm`](examples/nqueens.scm)
114 |   solves N-Queens for 6.
115 | 
116 | - [`dynamic-wind-example.scm`](examples/dynamic-wind-example.scm)
117 |   demonstrates the example of `dynamic-wind` in R5RS.
118 | 
119 | - [`amb.scm`](examples/amb.scm)
120 |   demonstrates a non-deterministic evaluation with `call/cc`.
121 | 
122 | - [`yin-yang-puzzle.scm`](examples/yin-yang-puzzle.scm)
123 |   runs the yin-yang puzzle with `call/cc`.
124 | 
125 | ```
126 | $ guile scm.scm < examples/fib90.scm 
127 | 2880067194370816120
128 | $ guile scm.scm < examples/nqueens.scm
129 | ((5 3 1 6 4 2) (4 1 5 2 6 3) (3 6 2 5 1 4) (2 4 6 1 3 5))
130 | $ guile scm.scm < examples/dynamic-wind-example.scm 
131 | (connect talk1 disconnect connect talk2 disconnect)
132 | $ guile scm.scm < examples/amb.scm
133 | ((1 A) (1 B) (1 C) (2 A) (2 B) (2 C) (3 A) (3 B) (3 C))
134 | $ guile scm.scm < examples/yin-yang-puzzle.scm | head
135 | 
136 | *
137 | **
138 | ***
139 | ****
140 | *****
141 | ******
142 | *******
143 | ********
144 | *********
145 | $ 
146 | ```
147 | 
148 | 
149 | <a name="performance"></a>
150 | ## Performance
151 | 
152 | The following table shows the times to run [`scm.scm`](scm.scm) `<` [`examples/nqueens.scm`](examples/nqueens.scm) on each Schemes.
153 | I used MacBook Pro (15-inch, 2016), 2.6GHz Core i7, 16GB 2133MHz LPDDR3, macOS Mojave 10.14.6.
154 | 
155 | | Scheme                                                                                     | Compiled/Executed on                                  | Time [sec] | Rel. Speed |
156 | |:-------------------------------------------------------------------------------------------|:------------------------------------------------------|-----------:|-----------:|
157 | | GNU Guile                                                                            2.2.7 | `guile`                                               |    0.13    |   14.4     |
158 | | [little-scheme-in-cs](https://github.com/nukata/little-scheme-in-cs)                 1.1.0 | .NET Core 3.1.2: `dotnet build -c Release`            |    1.87    |    1.00    |
159 | | [little-scheme-in-go](https://github.com/nukata/little-scheme-in-go)                 1.2.0 | Go 1.14.2: `go build`                                 |    2.00    |    0.94    |
160 | | [little-scheme-in-java](https://github.com/nukata/little-scheme-in-java)             1.1.0 | AdoptOpenJDK jdk-11.0.6+10                            |    2.02    |    0.93    |
161 | | [little-scheme-in-crystal](https://github.com/nukata/little-scheme-in-crystal)       0.2.0 | Crystal 0.34.0: `crystal build --release scm.cr`      |    2.15    |    0.87    |
162 | | [little-scheme-in-lisp](https://github.com/nukata/little-scheme-in-lisp)             0.4.0 | SBCL 2.0.2: `sbcl --script scm.l`                     |    2.38    |    0.79    |
163 | | [little-scheme-in-kotlin](https://github.com/nukata/little-scheme-in-kotlin)         0.2.0 | Kotlin 1.3.71/AdoptOpenJDK jdk-11.0.6+10              |    2.38    |    0.79    |
164 | | [little-scheme-in-cs](https://github.com/nukata/little-scheme-in-cs)                 1.1.0 | Mono 6.8.0: `csc -o -r:System.Numerics.dll *.cs`      |    2.77    |    0.68    |
165 | | [little-scheme-in-dart](https://github.com/nukata/little-scheme-in-dart)             0.4.0 | Dart 2.7.2: `dart scm.dart`                           |    3.71    |    0.50    |
166 | | [little-scheme-in-dart](https://github.com/nukata/little-scheme-in-dart)             0.4.0 | Dart 2.7.2: `dart2native scm.dart`; `./scm.exe`       |    3.72    |    0.50    |
167 | | [little-scheme-in-python](https://github.com/nukata/little-scheme-in-python)         3.2.0 | PyPy 7.3.0 (Python 2.7.13): `pypy scm.py`             |    4.73    |    0.40    |
168 | | [little-scheme-in-python](https://github.com/nukata/little-scheme-in-python)         3.2.0 | PyPy 7.3.0 (Python 3.6.9): `pypy3 scm.py`             |    5.19    |    0.36    |
169 | | [little-scheme-in-typescript](https://github.com/nukata/little-scheme-in-typescript) 1.2.1 | TypeScript 3.8.3/Node.js 13.12.0: `tsc -t ESNext ...` |    7.17    |    0.26    |
170 | | [little-scheme-in-crystal](https://github.com/nukata/little-scheme-in-crystal)       0.2.0 | Crystal 0.34.0: `crystal scm.cr`                      |    9.88    |    0.19    |
171 | | [little-scheme-in-php](https://github.com/nukata/little-scheme-in-php)               0.3.0 | PHP 7.1.33: `php scm.php`                             |   44.84    |    0.04    |
172 | | [little-scheme-in-python](https://github.com/nukata/little-scheme-in-python)         3.2.0 | Python 3.8.2: `python3 scm.py`                        |   81.72    |    0.02    |
173 | | [little-scheme-in-ruby](https://github.com/nukata/little-scheme-in-ruby)             0.3.0 | Ruby 2.3.7: `ruby scm.rb`                             |   84.80    |    0.02    |
174 | | [little-scheme-in-python](https://github.com/nukata/little-scheme-in-python)         3.2.0 | Python 2.7.16: `python scm.py`                        |   88.78    |    0.02    |
175 | 
176 | 
177 | <a name="tower"></a>
178 | ## Tower of meta-circular interpreters
179 | 
180 | Being meta-circular, this interpreter is able to run itself recursively.
181 | 
182 |  1. Copy the interpeter file `scm.scm` to `scm-scm.scm`.
183 | 
184 |  2. Comment out the last line `(read-eval-print-loop)` of `scm-scm.scm`.
185 | 
186 | ```Scheme
187 | ;; (read-eval-print-loop)
188 | ```
189 | 
190 |  3. Append two new lines `(global-eval '(begin` and `))` to `scm-scm.scm`.
191 | 
192 | ```Scheme
193 | ;; (read-eval-print-loop)
194 | (global-eval '(begin
195 | ))
196 | ```
197 | 
198 |  4. Insert the whole contents of `scm.scm` between the new lines.
199 | 
200 | ```Scheme
201 | ;; (read-eval-print-loop)
202 | (global-eval '(begin
203 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
204 | ...
205 | (read-eval-print-loop)
206 | ))
207 | ```
208 | 
209 |  5. Run `scm-scm.scm` on another Scheme.
210 | 
211 | For your convenience, I have built it as
212 | [`tower/scm-scm.scm`](tower/scm-scm.scm).
213 | 
214 | ```
215 | $ little-scheme-in-go tower/scm-scm.scm
216 | (+ 5 6)
217 | => 11
218 | +
219 | => ($Intrinsic $Closure (x) ((+ (fst x) (snd x))) #<(op):((if (eq? op (quote car)) CAR_ (if (eq? op 
220 | (quote cdr)) CDR_ (if (pair? op) (set! CDR_ (car op)) (_error "unknown op" op))))):#<| CAR_ CDR_ Glo
221 | balEnv>>)
222 | ```
223 | 
224 | Note that the _intrinsic_ function `+` is now implemented by a _closure_
225 | of `scm.scm`, the underlying Scheme here.
226 | 
227 | You can repeat the above process any times.
228 | Try [`tower/scm-scm-scm.scm`](tower/scm-scm-scm.scm) and you will find it runs
229 | prohibitively _slowly_ as might be expected.
230 | 
231 | ```
232 | $ time ./little-scheme-in-go examples/yin-yang-puzzle.scm | head -4
233 | 
234 | *
235 | **
236 | ***
237 | 
238 | real	0m0.007s
239 | user	0m0.004s
240 | sys	0m0.005s
241 | $ time ./little-scheme-in-go scm.scm < examples/yin-yang-puzzle.scm | head -4
242 | 
243 | *
244 | **
245 | ***
246 | 
247 | real	0m0.010s
248 | user	0m0.006s
249 | sys	0m0.005s
250 | $ time ./little-scheme-in-go tower/scm-scm.scm < examples/yin-yang-puzzle.scm | head -4
251 | 
252 | *
253 | **
254 | ***
255 | 
256 | real	0m0.386s
257 | user	0m0.434s
258 | sys	0m0.026s
259 | $ time ./little-scheme-in-go tower/scm-scm-scm.scm < examples/yin-yang-puzzle.scm | head -4
260 | 
261 | *
262 | **
263 | ***
264 | 
265 | real	1m46.486s
266 | user	2m33.903s
267 | sys	0m5.011s
268 | $ 
269 | ```
270 | 
271 | 
272 | <a name="performanceOnTower"></a>
273 | ## Performance on the tower
274 | 
275 | The following table shows the times to run [`tower/scm-scm.scm`](tower/scm-scm.scm) `<` [`examples/nqueens.scm`](examples/nqueens.scm) on each Schemes.
276 | I used the same MacBook Pro as above.
277 | 
278 | | Scheme                                                                                     | Compiled/Executed on                                  | Time [sec] | Rel. Speed |
279 | |:-------------------------------------------------------------------------------------------|:------------------------------------------------------|-----------:|-----------:|
280 | | GNU Guile                                                                            2.2.7 | `guile`                                               |    27.32   |   18.5     |
281 | | [little-scheme-in-cs](https://github.com/nukata/little-scheme-in-cs)                 1.1.0 | .NET Core 3.1.2: `dotnet build -c Release`            |   506.15   |    1.00    |
282 | | [little-scheme-in-java](https://github.com/nukata/little-scheme-in-java)             1.1.0 | AdoptOpenJDK jdk-11.0.6+10                            |   506.79   |    1.00    |
283 | | [little-scheme-in-kotlin](https://github.com/nukata/little-scheme-in-kotlin)         0.2.0 | Kotlin 1.3.71/AdoptOpenJDK jdk-11.0.6+10              |   598.57   |    0.85    |
284 | | [little-scheme-in-go](https://github.com/nukata/little-scheme-in-go)                 1.2.0 | Go 1.14.2: `go build`                                 |   604.27   |    0.84    |
285 | | [little-scheme-in-crystal](https://github.com/nukata/little-scheme-in-crystal)       0.2.0 | Crystal 0.34.0: `crystal build --release scm.cr`      |   624.52   |    0.81    |
286 | | [little-scheme-in-lisp](https://github.com/nukata/little-scheme-in-lisp)             0.4.0 | SBCL 2.0.2: `sbcl --script scm.l`                     |   676.82   |    0.75    |
287 | 


--------------------------------------------------------------------------------
/examples/amb.scm:
--------------------------------------------------------------------------------
 1 | ;; Amb (ambiguous) using continuations
 2 | ;; cf. https://stackoverflow.com/questions/49390161
 3 | 
 4 | (define current-continuation
 5 |   (lambda ()
 6 |     (call/cc (lambda (cc)
 7 |                ;; `cc` will be the value of `k` in `amb`.
 8 |                (cc cc)))))
 9 | 
10 | (define fail-stack '())                 ; list of continuations
11 | 
12 | (define fail
13 |   (lambda ()
14 |     (if (pair? fail-stack)
15 |         ((lambda (bt-point remaining-stack)
16 |            (set! fail-stack remaining-stack)
17 |            ;; `bt-point` will be the value of `k` in `amb`.
18 |            (bt-point bt-point))
19 |          (car fail-stack)
20 |          (cdr fail-stack))
21 |       (error "no backtracking poins" fail-stack))))
22 | 
23 | (define amb
24 |   (lambda (choices)
25 |     ((lambda (k)
26 |        (if (null? choices)
27 |            (fail)
28 |          ((lambda (choice remaining-choices)
29 |             (set! choices remaining-choices)
30 |             (set! fail-stack (cons k fail-stack))
31 |             choice)
32 |           (car choices)
33 |           (cdr choices))))
34 |      (current-continuation))))
35 | 
36 | ;;----------------------------------------------------------------------
37 | 
38 | ;; (fold f x '(a b c d)) => (f (f (f (f x a) b) c) d)
39 | (define fold
40 |   (lambda (fun x ys)
41 |     (if (null? ys)
42 |         x
43 |       (fold fun
44 |             (fun x (car ys))
45 |             (cdr ys)))))
46 | 
47 | ;; (_reverse '(a b c d)) => (d c b a)
48 | (define _reverse
49 |   (lambda (xs)
50 |     (fold (lambda (xs y) (cons y xs))
51 |           '()
52 |           xs)))
53 | 
54 | ;; Create a list of the results which `(fun)` returns successively on
55 | ;; backtracking over `amb` in `fun`.  cf. Prolog findall/3
56 | (define find-all
57 |   (lambda (fun)
58 |     ((lambda (results)
59 |        (call/cc (lambda (end-loop)
60 |                   (set! fail-stack (cons end-loop fail-stack))
61 |                   ;; loop:
62 |                   ((lambda (r)
63 |                      (set! results (cons r results)))
64 |                    (fun))
65 |                   (fail)))              ; goto loop or goto end-loop
66 |        ;; end-loop:
67 |        (_reverse results))
68 |      '())))
69 | 
70 | (display (find-all (lambda ()
71 |                      ((lambda (x)
72 |                         (list x (amb '(A B C))))
73 |                       (amb '(1 2 3))))))
74 | (newline)
75 | ;; => ((1 A) (1 B) (1 C) (2 A) (2 B) (2 C) (3 A) (3 B) (3 C))
76 | 


--------------------------------------------------------------------------------
/examples/dynamic-wind-example.scm:
--------------------------------------------------------------------------------
 1 | ;; An implementation of dynamic-wind (originally by Aubrey Jaffer in 1992)
 2 | ;; and its application to the example code at sec. 6.4 in R5RS
 3 | ;; cf. https://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1992/msg00194.html
 4 | ;;     https://schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.4
 5 | 
 6 | (define *winds* '())
 7 | 
 8 | (define dynamic-wind
 9 |   (lambda (<thunk1> <thunk2> <thunk3>)
10 |     (<thunk1>)
11 |     (set! *winds* (cons (cons <thunk1> <thunk3>) *winds*))
12 |     ((lambda (ans)
13 |        (set! *winds* (cdr *winds*))
14 |        (<thunk3>)
15 |        ans)
16 |      (<thunk2>))))
17 | 
18 | (define call/cc
19 |   ((lambda (oldcc)
20 |      (lambda (proc)
21 |        (define winds *winds*)
22 |        (oldcc (lambda (cont)
23 |                 (proc (lambda (c2)
24 |                         (_dynamic-do-winds *winds* winds)
25 |                         (cont c2)))))))
26 |    call/cc))
27 | 
28 | (define _dynamic-do-winds
29 |   (lambda (from to)
30 |     (set! *winds* from)
31 |     (if (not (eq? from to))
32 |         (if (null? from)
33 |             (begin (_dynamic-do-winds from (cdr to))
34 |                    ((car (car to))))
35 |           (if (null? to)
36 |               (begin ((cdr (car from)))
37 |                      (_dynamic-do-winds (cdr from) to))
38 |             (begin ((cdr (car from)))
39 |                    (_dynamic-do-winds (cdr from) (cdr to))
40 |                    ((car (car to)))))))
41 |     (set! *winds* to)))
42 | 
43 | 
44 | (define length
45 |   (lambda (lst)
46 |     (if (null? lst)
47 |         0
48 |       (+ 1 (length (cdr lst))))))
49 | 
50 | (define reverse
51 |   (lambda (lst)
52 |     (define _reverse2
53 |       (lambda (lst result)
54 |         (if (null? lst)
55 |             result
56 |           (_reverse2 (cdr lst) (cons (car lst) result)))))
57 |     (_reverse2 lst '())))
58 | 
59 | (display
60 |  ((lambda (path c)
61 |     (define add (lambda (s)
62 |                   (set! path (cons s path))))
63 |     (dynamic-wind
64 |       (lambda () (add 'connect))
65 |       (lambda () (add (call/cc
66 |                        (lambda (c0)
67 |                          (set! c c0)
68 |                          'talk1))))
69 |       (lambda () (add 'disconnect)))
70 |     (if (< (length path) 4)
71 |         (c 'talk2)
72 |       (reverse path)))
73 |   '() #f))
74 | (newline)
75 | ;; => (connect talk1 disconnect connect talk2 disconnect)
76 | 


--------------------------------------------------------------------------------
/examples/fib90.scm:
--------------------------------------------------------------------------------
 1 | ;; Fibonacci numbers: F(n) = F(n-1) + F(n-2) with F(0) = 0 and F(1) = 1. 
 2 | ;; cf. https://oeis.org/A000045
 3 | (define fibonacci
 4 |   (lambda (n)
 5 |     (define _fib
 6 |       (lambda (i F_i F_i+1)
 7 |         (if (= i n)
 8 |             F_i
 9 |           (_fib (+ i 1) F_i+1 (+ F_i F_i+1)))))
10 |     (_fib 0 0 1)))                      ; i=0, F(0)=0, F(1)=1
11 | 
12 | (display (fibonacci 90))
13 | (newline)
14 | ;; => 2880067194370816120
15 | 


--------------------------------------------------------------------------------
/examples/nqueens.scm:
--------------------------------------------------------------------------------
 1 | ;; N-Queens solver in Scheme
 2 | (define nqueens
 3 |   (lambda (n)
 4 |     (define loop
 5 |       (lambda (lst result)
 6 |         (if (null? lst)
 7 |             result
 8 |           ((lambda (candidate)
 9 |              (set! lst (cdr lst))
10 |              (if (safe-positions? candidate)
11 |                  (if (= (_length candidate) n)
12 |                      (set! result (cons candidate result))
13 |                    (set! lst (_append (cons-range n candidate) lst))))
14 |              (loop lst result))
15 |            (car lst)))))
16 |     (loop (cons-range n '()) '())))
17 | 
18 | (define _length
19 |   (lambda (lst)
20 |     (if (null? lst)
21 |         0
22 |       (+ 1 (_length (cdr lst))))))
23 | 
24 | (define _append
25 |   (lambda (lst1 lst2)
26 |     (if (null? lst1)
27 |         lst2
28 |       (cons (car lst1) (_append (cdr lst1) lst2)))))
29 | 
30 | (define safe-positions? ; (safe-positions? '(3 4 1)) => #f i.e. conflicted
31 |   (lambda (lst)
32 |     (if (null? (cdr lst))
33 |         #t
34 |       ((lambda (loop)
35 |          (set! loop
36 |                (lambda (me high low rest)
37 |                  (if (null? rest)
38 |                      #t
39 |                    ((lambda (target)
40 |                       (if (= target me)
41 |                           #f
42 |                         (if (= target high)
43 |                             #f
44 |                           (if (= target low)
45 |                               #f
46 |                             (loop me (+ high 1) (- low 1) (cdr rest))))))
47 |                     (car rest)))))
48 |          ((lambda (me)
49 |             (loop me (+ me 1) (- me 1) (cdr lst)))
50 |           (car lst)))
51 |        '()))))
52 | 
53 | (define cons-range     ; (cons-range 3 x) => ((3 . x) (2 . x) (1 . x))
54 |   (lambda (n lst)
55 |     (if (= n 0)
56 |         '()
57 |       (cons (cons n lst) (cons-range (- n 1) lst)))))
58 | 
59 | (display (nqueens 6))
60 | (newline)
61 | ;; => ((5 3 1 6 4 2) (4 1 5 2 6 3) (3 6 2 5 1 4) (2 4 6 1 3 5)
62 | 


--------------------------------------------------------------------------------
/examples/yin-yang-puzzle.scm:
--------------------------------------------------------------------------------
 1 | ;; The yin-yang puzzle 
 2 | ;; cf. https://en.wikipedia.org/wiki/Call-with-current-continuation
 3 | 
 4 | ((lambda (yin)
 5 |    ((lambda (yang)
 6 |       (yin yang))
 7 |     ((lambda (cc)
 8 |        (display '*)
 9 |        cc)
10 |      (call/cc (lambda (c) c)))))
11 |  ((lambda (cc)
12 |     (newline)
13 |     cc)
14 |   (call/cc (lambda (c) c))))
15 | 
16 | ;; => \n*\n**\n***\n****\n*****\n******\n...
17 | 


--------------------------------------------------------------------------------
/scm.scm:
--------------------------------------------------------------------------------
  1 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
  2 | 
  3 | ;; Intrinsic:    ($Intrinsic . function)
  4 | ;; Continuation: ($Continuation . function)
  5 | ;; Closure:      ($Closure params body env)
  6 | 
  7 | (define fst car)
  8 | (define snd (lambda (x) (car (cdr x))))
  9 | (define trd (lambda (x) (car (cdr (cdr x)))))
 10 | (define None (set! fst fst))
 11 | (define exit-with #f)               ; to be set at global-eval
 12 | 
 13 | (define _error
 14 |   (lambda (reason arg)
 15 |     (display "Error: ") (display reason) (display ": ") (display arg)
 16 |     (newline)
 17 |     (exit-with None)))
 18 | 
 19 | ;; (_ CAR_ CDR_) returns a mutable cell to construct environments.
 20 | ;; (define x (_ 'a 'b))
 21 | ;; (x 'car) => a
 22 | ;; (x 'cdr) => b
 23 | ;; (x '(c)) => None; (x 'cdr) = c
 24 | (define _
 25 |   (lambda (CAR_ CDR_)
 26 |     (lambda (op)
 27 |       (if (eq? op 'car)
 28 |           CAR_
 29 |         (if (eq? op 'cdr)
 30 |             CDR_
 31 |           (if (pair? op)
 32 |               (set! CDR_ (car op))
 33 |             (_error "unknown op" op)))))))
 34 | 
 35 | ;; Return a list of keys of the global environment.
 36 | (define globals
 37 |   (lambda (loop)
 38 |     (set! loop (lambda (env result)
 39 |                  (if (null? env)
 40 |                      result
 41 |                    (loop (env 'cdr)
 42 |                          (cons ((env 'car) 'car)
 43 |                                result)))))
 44 |     (loop (Global-Env 'cdr) '()))) ; Take cdr to skip the frame marker.
 45 | 
 46 | (define _i
 47 |   (lambda (name fun)
 48 |     (_ name (cons '$Intrinsic fun))))
 49 | 
 50 | (define Global-Env
 51 |   (_ (_i '< (lambda (x) (< (fst x) (snd x))))
 52 |      (_ (_i '= (lambda (x) (= (fst x) (snd x))))
 53 |         (_ (_i 'number? (lambda (x) (number? (fst x))))
 54 |            (_ (_i 'error (lambda (x) (_error (fst x) (snd x)))) ; cf. SRFI-23
 55 |               (_ (_i 'globals globals)
 56 |                  '()))))))
 57 | 
 58 | (set! Global-Env
 59 |       (_ (_i 'display (lambda (x) (display (fst x))))
 60 |          (_ (_i 'newline (lambda (x) (newline)))
 61 |             (_ (_i 'read (lambda (x) (read)))
 62 |                (_ (_i 'eof-object? (lambda (x) (eof-object? (fst x))))
 63 |                   (_ (_i 'symbol? (lambda (x) (symbol? (fst x))))
 64 |                      (_ (_ 'call/cc 'call/cc)
 65 |                         (_ (_ 'apply 'apply)
 66 |                            (_ (_i '+ (lambda (x) (+ (fst x) (snd x))))
 67 |                               (_ (_i '- (lambda (x) (- (fst x) (snd x))))
 68 |                                  (_ (_i '* (lambda (x) (* (fst x) (snd x))))
 69 |                                     Global-Env)))))))))))
 70 | 
 71 | (set! Global-Env
 72 |       (_ (_ '() '())                    ; frame marker
 73 |          (_ (_i 'car (lambda (x) (car (fst x))))
 74 |             (_ (_i 'cdr (lambda (x) (cdr (fst x))))
 75 |                (_ (_i 'cons (lambda (x) (cons (fst x) (snd x))))
 76 |                   (_ (_i 'eq? (lambda (x) (eq? (fst x) (snd x))))
 77 |                      (_ (_i 'pair? (lambda (x) (pair? (fst x))))
 78 |                         (_ (_i 'null? (lambda (x) (null? (fst x))))
 79 |                            (_ (_i 'not (lambda (x) (not (fst x))))
 80 |                               (_ (_i 'list (lambda (x) x))
 81 |                                  Global-Env))))))))))
 82 | 
 83 | ;; Evaluate an expression with an environment and a continuation.
 84 | (define evaluate
 85 |   (lambda (exp env k)
 86 |     (if (pair? exp)
 87 |         ((lambda (kar kdr)
 88 |            (if (eq? kar 'quote)         ; (quote e)
 89 |                (k (fst kdr))
 90 |              (if (eq? kar 'if)          ; (if e1 e2) or (if e1 e2 e3)
 91 |                  (if (null? (cdr (cdr kdr)))
 92 |                      (evaluate (fst kdr) env
 93 |                                (lambda (x)
 94 |                                  (if x
 95 |                                      (evaluate (snd kdr) env k)
 96 |                                    (evaluate None env k))))
 97 |                    (evaluate (fst kdr) env
 98 |                              (lambda (x)
 99 |                                (if x
100 |                                    (evaluate (snd kdr) env k)
101 |                                  (evaluate (trd kdr) env k)))))
102 |                (if (eq? kar 'begin)     ; (begin e...)
103 |                    (eval-sequentially kdr env k)
104 |                  (if (eq? kar 'lambda)  ; (lambda (v...) e...)
105 |                      (k (list '$Closure (car kdr) (cdr kdr) env))
106 |                    (if (eq? kar 'define) ; (define v e)
107 |                        (evaluate (snd kdr) env
108 |                                  (lambda (x)
109 |                                    (k (define-var (fst kdr) x env))))
110 |                      (if (eq? kar 'set!) ; (set! v e)
111 |                          (evaluate (snd kdr) env
112 |                                    (lambda (x)
113 |                                      (k (set-var (look-for-pair (fst kdr) env)
114 |                                                  x))))
115 |                        (if (eq? kar '$Intrinsic)
116 |                            (k exp)
117 |                          (if (eq? kar '$Continuation)
118 |                              (k exp)
119 |                            (if (eq? kar '$Closure)
120 |                                (k exp)
121 |                              (evaluate kar env
122 |                                        (lambda (fun)
123 |                                          (evlis kdr env
124 |                                                 (lambda (arg)
125 |                                                   (apply-fun fun arg k)
126 |                                                   ))))))))))))))
127 |          (car exp)                      ; = kar
128 |          (cdr exp))                     ; = kdr
129 |       (if (symbol? exp)
130 |           (k ((look-for-pair exp env) 'cdr))
131 |         (k exp)))))                     ; as a number, #t, #f etc.
132 | 
133 | ;; Apply a function to arguments with a continuation.
134 | (define apply-fun
135 |   (lambda (fun arg k)
136 |     (if (eq? fun 'call/cc)
137 |         (apply-fun (fst arg) (list (cons '$Continuation k)) k)
138 |       (if (eq? fun 'apply)
139 |           (apply-fun (fst arg) (snd arg) k)
140 |         (if (pair? fun)
141 |             ((lambda (kar kdr)
142 |                (if (eq? kar '$Intrinsic)
143 |                    (k (kdr arg))
144 |                  (if (eq? kar '$Continuation)
145 |                      (kdr (fst arg))
146 |                    (if (eq? kar '$Closure)
147 |                        (eval-sequentially
148 |                         (snd kdr)       ; body
149 |                         (_ (_ '() '())  ; frame marker
150 |                            (prepend-defs-to-env (fst kdr) ; params
151 |                                                 arg
152 |                                                 (trd kdr))) ; env
153 |                         k)
154 |                      (_error "unknown functional pair" fun)))))
155 |              (car fun)
156 |              (cdr fun))
157 |           (_error "unknown function" fun))))))
158 | 
159 | ;; Evaluate each element of list sequentially to yield the last result.
160 | (define eval-sequentially
161 |   (lambda (explist env k)
162 |     (evaluate (car explist) env
163 |               (if (null? (cdr explist))
164 |                   k
165 |                 (lambda (x) (eval-sequentially (cdr explist) env k))))))
166 | 
167 | ;; Evaluate each element of list to construct a new list of the results.
168 | ;; (evlis '((* 1 2) (* 3 4)) Global-Env list) => (list '(2 12)) => ((2 12))
169 | (define evlis
170 |   (lambda (arg env k)
171 |     (if (null? arg)
172 |         (k '())
173 |       (evaluate (car arg) env
174 |                 (lambda (head)
175 |                   (evlis (cdr arg) env
176 |                          (lambda (tail)
177 |                            (k (cons head tail)))))))))
178 | 
179 | ;; env = (_ (_ '() '()) x); (deinfe-var 'a 1 env) => None;
180 | ;; env = (_ (_ '() '()) (_ (_ a 1) x))
181 | (define define-var
182 |   (lambda (v e env)
183 |     (if (null? ((env 'car) 'car))       ; Check for the frame marker.
184 |         (env (list (_ (_ v e)
185 |                       (env 'cdr))))
186 |       (_error "illegal frame marker" ((env 'car) 'car)))))
187 | 
188 | ;; x = (_ a 1); (set-var x 2) => None; x = (_ a 2)
189 | (define set-var
190 |   (lambda (pair e)
191 |     (pair (list e))))
192 | 
193 | ;; (look-for-pair 'b (_ (_ a 1) (_ (_ b 2) (_ (_ c 3) 'nil)))) => (_ b 2)
194 | (define look-for-pair
195 |   (lambda (key alist)
196 |     (if (null? alist)
197 |         (_error "not found" key)
198 |       (if (eq? key ((alist 'car) 'car))
199 |           (alist 'car)
200 |         (look-for-pair key (alist 'cdr))))))
201 | 
202 | ;; (prepend-defs-to-env '(a b) '(1 2) x) => (_ (_ a 1) (_ (_ b 1) x))
203 | (define prepend-defs-to-env
204 |   (lambda (keys data env)
205 |     (if (null? keys)
206 |         env
207 |       (_ (_ (car keys) (car data))
208 |          (prepend-defs-to-env (cdr keys) (cdr data) env)))))
209 | 
210 | ;; Evaluate an expression in the global environment.
211 | (define global-eval
212 |   (lambda (exp)
213 |     (call/cc (lambda (k)
214 |                (set! exit-with k)
215 |                (evaluate exp Global-Env (lambda (x) x))))))
216 | 
217 | ;; Repeat read-eval-print until End-of-File.
218 | (define read-eval-print-loop
219 |   (lambda ()
220 |     ((lambda (input)
221 |        (if (not (eof-object? input))
222 |            (begin
223 |              ((lambda (result)
224 |                 (if (not (eq? result None))
225 |                     (begin
226 |                       (display "=> ") (display result)
227 |                       (newline))))
228 |               (global-eval input))
229 |              (read-eval-print-loop))))
230 |      (read))))
231 | 
232 | (read-eval-print-loop)
233 | 


--------------------------------------------------------------------------------
/tower/scm-scm-scm.scm:
--------------------------------------------------------------------------------
  1 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
  2 | 
  3 | ;; Intrinsic:    ($Intrinsic . function)
  4 | ;; Continuation: ($Continuation . function)
  5 | ;; Closure:      ($Closure params body env)
  6 | 
  7 | (define fst car)
  8 | (define snd (lambda (x) (car (cdr x))))
  9 | (define trd (lambda (x) (car (cdr (cdr x)))))
 10 | (define None (set! fst fst))
 11 | (define exit-with #f)               ; to be set at global-eval
 12 | 
 13 | (define _error
 14 |   (lambda (reason arg)
 15 |     (display "Error: ") (display reason) (display ": ") (display arg)
 16 |     (newline)
 17 |     (exit-with None)))
 18 | 
 19 | ;; (_ CAR_ CDR_) returns a mutable cell to construct environments.
 20 | ;; (define x (_ 'a 'b))
 21 | ;; (x 'car) => a
 22 | ;; (x 'cdr) => b
 23 | ;; (x '(c)) => None; (x 'cdr) = c
 24 | (define _
 25 |   (lambda (CAR_ CDR_)
 26 |     (lambda (op)
 27 |       (if (eq? op 'car)
 28 |           CAR_
 29 |         (if (eq? op 'cdr)
 30 |             CDR_
 31 |           (if (pair? op)
 32 |               (set! CDR_ (car op))
 33 |             (_error "unknown op" op)))))))
 34 | 
 35 | ;; Return a list of keys of the global environment.
 36 | (define globals
 37 |   (lambda (loop)
 38 |     (set! loop (lambda (env result)
 39 |                  (if (null? env)
 40 |                      result
 41 |                    (loop (env 'cdr)
 42 |                          (cons ((env 'car) 'car)
 43 |                                result)))))
 44 |     (loop (Global-Env 'cdr) '()))) ; Take cdr to skip the frame marker.
 45 | 
 46 | (define _i
 47 |   (lambda (name fun)
 48 |     (_ name (cons '$Intrinsic fun))))
 49 | 
 50 | (define Global-Env
 51 |   (_ (_i '< (lambda (x) (< (fst x) (snd x))))
 52 |      (_ (_i '= (lambda (x) (= (fst x) (snd x))))
 53 |         (_ (_i 'number? (lambda (x) (number? (fst x))))
 54 |            (_ (_i 'error (lambda (x) (_error (fst x) (snd x)))) ; cf. SRFI-23
 55 |               (_ (_i 'globals globals)
 56 |                  '()))))))
 57 | 
 58 | (set! Global-Env
 59 |       (_ (_i 'display (lambda (x) (display (fst x))))
 60 |          (_ (_i 'newline (lambda (x) (newline)))
 61 |             (_ (_i 'read (lambda (x) (read)))
 62 |                (_ (_i 'eof-object? (lambda (x) (eof-object? (fst x))))
 63 |                   (_ (_i 'symbol? (lambda (x) (symbol? (fst x))))
 64 |                      (_ (_ 'call/cc 'call/cc)
 65 |                         (_ (_ 'apply 'apply)
 66 |                            (_ (_i '+ (lambda (x) (+ (fst x) (snd x))))
 67 |                               (_ (_i '- (lambda (x) (- (fst x) (snd x))))
 68 |                                  (_ (_i '* (lambda (x) (* (fst x) (snd x))))
 69 |                                     Global-Env)))))))))))
 70 | 
 71 | (set! Global-Env
 72 |       (_ (_ '() '())                    ; frame marker
 73 |          (_ (_i 'car (lambda (x) (car (fst x))))
 74 |             (_ (_i 'cdr (lambda (x) (cdr (fst x))))
 75 |                (_ (_i 'cons (lambda (x) (cons (fst x) (snd x))))
 76 |                   (_ (_i 'eq? (lambda (x) (eq? (fst x) (snd x))))
 77 |                      (_ (_i 'pair? (lambda (x) (pair? (fst x))))
 78 |                         (_ (_i 'null? (lambda (x) (null? (fst x))))
 79 |                            (_ (_i 'not (lambda (x) (not (fst x))))
 80 |                               (_ (_i 'list (lambda (x) x))
 81 |                                  Global-Env))))))))))
 82 | 
 83 | ;; Evaluate an expression with an environment and a continuation.
 84 | (define evaluate
 85 |   (lambda (exp env k)
 86 |     (if (pair? exp)
 87 |         ((lambda (kar kdr)
 88 |            (if (eq? kar 'quote)         ; (quote e)
 89 |                (k (fst kdr))
 90 |              (if (eq? kar 'if)          ; (if e1 e2) or (if e1 e2 e3)
 91 |                  (if (null? (cdr (cdr kdr)))
 92 |                      (evaluate (fst kdr) env
 93 |                                (lambda (x)
 94 |                                  (if x
 95 |                                      (evaluate (snd kdr) env k)
 96 |                                    (evaluate None env k))))
 97 |                    (evaluate (fst kdr) env
 98 |                              (lambda (x)
 99 |                                (if x
100 |                                    (evaluate (snd kdr) env k)
101 |                                  (evaluate (trd kdr) env k)))))
102 |                (if (eq? kar 'begin)     ; (begin e...)
103 |                    (eval-sequentially kdr env k)
104 |                  (if (eq? kar 'lambda)  ; (lambda (v...) e...)
105 |                      (k (list '$Closure (car kdr) (cdr kdr) env))
106 |                    (if (eq? kar 'define) ; (define v e)
107 |                        (evaluate (snd kdr) env
108 |                                  (lambda (x)
109 |                                    (k (define-var (fst kdr) x env))))
110 |                      (if (eq? kar 'set!) ; (set! v e)
111 |                          (evaluate (snd kdr) env
112 |                                    (lambda (x)
113 |                                      (k (set-var (look-for-pair (fst kdr) env)
114 |                                                  x))))
115 |                        (if (eq? kar '$Intrinsic)
116 |                            (k exp)
117 |                          (if (eq? kar '$Continuation)
118 |                              (k exp)
119 |                            (if (eq? kar '$Closure)
120 |                                (k exp)
121 |                              (evaluate kar env
122 |                                        (lambda (fun)
123 |                                          (evlis kdr env
124 |                                                 (lambda (arg)
125 |                                                   (apply-fun fun arg k)
126 |                                                   ))))))))))))))
127 |          (car exp)                      ; = kar
128 |          (cdr exp))                     ; = kdr
129 |       (if (symbol? exp)
130 |           (k ((look-for-pair exp env) 'cdr))
131 |         (k exp)))))                     ; as a number, #t, #f etc.
132 | 
133 | ;; Apply a function to arguments with a continuation.
134 | (define apply-fun
135 |   (lambda (fun arg k)
136 |     (if (eq? fun 'call/cc)
137 |         (apply-fun (fst arg) (list (cons '$Continuation k)) k)
138 |       (if (eq? fun 'apply)
139 |           (apply-fun (fst arg) (snd arg) k)
140 |         (if (pair? fun)
141 |             ((lambda (kar kdr)
142 |                (if (eq? kar '$Intrinsic)
143 |                    (k (kdr arg))
144 |                  (if (eq? kar '$Continuation)
145 |                      (kdr (fst arg))
146 |                    (if (eq? kar '$Closure)
147 |                        (eval-sequentially
148 |                         (snd kdr)       ; body
149 |                         (_ (_ '() '())  ; frame marker
150 |                            (prepend-defs-to-env (fst kdr) ; params
151 |                                                 arg
152 |                                                 (trd kdr))) ; env
153 |                         k)
154 |                      (_error "unknown functional pair" fun)))))
155 |              (car fun)
156 |              (cdr fun))
157 |           (_error "unknown function" fun))))))
158 | 
159 | ;; Evaluate each element of list sequentially to yield the last result.
160 | (define eval-sequentially
161 |   (lambda (explist env k)
162 |     (evaluate (car explist) env
163 |               (if (null? (cdr explist))
164 |                   k
165 |                 (lambda (x) (eval-sequentially (cdr explist) env k))))))
166 | 
167 | ;; Evaluate each element of list to construct a new list of the results.
168 | ;; (evlis '((* 1 2) (* 3 4)) Global-Env list) => (list '(2 12)) => ((2 12))
169 | (define evlis
170 |   (lambda (arg env k)
171 |     (if (null? arg)
172 |         (k '())
173 |       (evaluate (car arg) env
174 |                 (lambda (head)
175 |                   (evlis (cdr arg) env
176 |                          (lambda (tail)
177 |                            (k (cons head tail)))))))))
178 | 
179 | ;; env = (_ (_ '() '()) x); (deinfe-var 'a 1 env) => None;
180 | ;; env = (_ (_ '() '()) (_ (_ a 1) x))
181 | (define define-var
182 |   (lambda (v e env)
183 |     (if (null? ((env 'car) 'car))       ; Check for the frame marker.
184 |         (env (list (_ (_ v e)
185 |                       (env 'cdr))))
186 |       (_error "illegal frame marker" ((env 'car) 'car)))))
187 | 
188 | ;; x = (_ a 1); (set-var x 2) => None; x = (_ a 2)
189 | (define set-var
190 |   (lambda (pair e)
191 |     (pair (list e))))
192 | 
193 | ;; (look-for-pair 'b (_ (_ a 1) (_ (_ b 2) (_ (_ c 3) 'nil)))) => (_ b 2)
194 | (define look-for-pair
195 |   (lambda (key alist)
196 |     (if (null? alist)
197 |         (_error "not found" key)
198 |       (if (eq? key ((alist 'car) 'car))
199 |           (alist 'car)
200 |         (look-for-pair key (alist 'cdr))))))
201 | 
202 | ;; (prepend-defs-to-env '(a b) '(1 2) x) => (_ (_ a 1) (_ (_ b 1) x))
203 | (define prepend-defs-to-env
204 |   (lambda (keys data env)
205 |     (if (null? keys)
206 |         env
207 |       (_ (_ (car keys) (car data))
208 |          (prepend-defs-to-env (cdr keys) (cdr data) env)))))
209 | 
210 | ;; Evaluate an expression in the global environment.
211 | (define global-eval
212 |   (lambda (exp)
213 |     (call/cc (lambda (k)
214 |                (set! exit-with k)
215 |                (evaluate exp Global-Env (lambda (x) x))))))
216 | 
217 | ;; Repeat read-eval-print until End-of-File.
218 | (define read-eval-print-loop
219 |   (lambda ()
220 |     ((lambda (input)
221 |        (if (not (eof-object? input))
222 |            (begin
223 |              ((lambda (result)
224 |                 (if (not (eq? result None))
225 |                     (begin
226 |                       (display "=> ") (display result)
227 |                       (newline))))
228 |               (global-eval input))
229 |              (read-eval-print-loop))))
230 |      (read))))
231 | 
232 | ;; (read-eval-print-loop)
233 | (global-eval '(begin
234 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
235 | 
236 | ;; Intrinsic:    ($Intrinsic . function)
237 | ;; Continuation: ($Continuation . function)
238 | ;; Closure:      ($Closure params body env)
239 | 
240 | (define fst car)
241 | (define snd (lambda (x) (car (cdr x))))
242 | (define trd (lambda (x) (car (cdr (cdr x)))))
243 | (define None (set! fst fst))
244 | (define exit-with #f)               ; to be set at global-eval
245 | 
246 | (define _error
247 |   (lambda (reason arg)
248 |     (display "Error: ") (display reason) (display ": ") (display arg)
249 |     (newline)
250 |     (exit-with None)))
251 | 
252 | ;; (_ CAR_ CDR_) returns a mutable cell to construct environments.
253 | ;; (define x (_ 'a 'b))
254 | ;; (x 'car) => a
255 | ;; (x 'cdr) => b
256 | ;; (x '(c)) => None; (x 'cdr) = c
257 | (define _
258 |   (lambda (CAR_ CDR_)
259 |     (lambda (op)
260 |       (if (eq? op 'car)
261 |           CAR_
262 |         (if (eq? op 'cdr)
263 |             CDR_
264 |           (if (pair? op)
265 |               (set! CDR_ (car op))
266 |             (_error "unknown op" op)))))))
267 | 
268 | ;; Return a list of keys of the global environment.
269 | (define globals
270 |   (lambda (loop)
271 |     (set! loop (lambda (env result)
272 |                  (if (null? env)
273 |                      result
274 |                    (loop (env 'cdr)
275 |                          (cons ((env 'car) 'car)
276 |                                result)))))
277 |     (loop (Global-Env 'cdr) '()))) ; Take cdr to skip the frame marker.
278 | 
279 | (define _i
280 |   (lambda (name fun)
281 |     (_ name (cons '$Intrinsic fun))))
282 | 
283 | (define Global-Env
284 |   (_ (_i '< (lambda (x) (< (fst x) (snd x))))
285 |      (_ (_i '= (lambda (x) (= (fst x) (snd x))))
286 |         (_ (_i 'number? (lambda (x) (number? (fst x))))
287 |            (_ (_i 'error (lambda (x) (_error (fst x) (snd x)))) ; cf. SRFI-23
288 |               (_ (_i 'globals globals)
289 |                  '()))))))
290 | 
291 | (set! Global-Env
292 |       (_ (_i 'display (lambda (x) (display (fst x))))
293 |          (_ (_i 'newline (lambda (x) (newline)))
294 |             (_ (_i 'read (lambda (x) (read)))
295 |                (_ (_i 'eof-object? (lambda (x) (eof-object? (fst x))))
296 |                   (_ (_i 'symbol? (lambda (x) (symbol? (fst x))))
297 |                      (_ (_ 'call/cc 'call/cc)
298 |                         (_ (_ 'apply 'apply)
299 |                            (_ (_i '+ (lambda (x) (+ (fst x) (snd x))))
300 |                               (_ (_i '- (lambda (x) (- (fst x) (snd x))))
301 |                                  (_ (_i '* (lambda (x) (* (fst x) (snd x))))
302 |                                     Global-Env)))))))))))
303 | 
304 | (set! Global-Env
305 |       (_ (_ '() '())                    ; frame marker
306 |          (_ (_i 'car (lambda (x) (car (fst x))))
307 |             (_ (_i 'cdr (lambda (x) (cdr (fst x))))
308 |                (_ (_i 'cons (lambda (x) (cons (fst x) (snd x))))
309 |                   (_ (_i 'eq? (lambda (x) (eq? (fst x) (snd x))))
310 |                      (_ (_i 'pair? (lambda (x) (pair? (fst x))))
311 |                         (_ (_i 'null? (lambda (x) (null? (fst x))))
312 |                            (_ (_i 'not (lambda (x) (not (fst x))))
313 |                               (_ (_i 'list (lambda (x) x))
314 |                                  Global-Env))))))))))
315 | 
316 | ;; Evaluate an expression with an environment and a continuation.
317 | (define evaluate
318 |   (lambda (exp env k)
319 |     (if (pair? exp)
320 |         ((lambda (kar kdr)
321 |            (if (eq? kar 'quote)         ; (quote e)
322 |                (k (fst kdr))
323 |              (if (eq? kar 'if)          ; (if e1 e2) or (if e1 e2 e3)
324 |                  (if (null? (cdr (cdr kdr)))
325 |                      (evaluate (fst kdr) env
326 |                                (lambda (x)
327 |                                  (if x
328 |                                      (evaluate (snd kdr) env k)
329 |                                    (evaluate None env k))))
330 |                    (evaluate (fst kdr) env
331 |                              (lambda (x)
332 |                                (if x
333 |                                    (evaluate (snd kdr) env k)
334 |                                  (evaluate (trd kdr) env k)))))
335 |                (if (eq? kar 'begin)     ; (begin e...)
336 |                    (eval-sequentially kdr env k)
337 |                  (if (eq? kar 'lambda)  ; (lambda (v...) e...)
338 |                      (k (list '$Closure (car kdr) (cdr kdr) env))
339 |                    (if (eq? kar 'define) ; (define v e)
340 |                        (evaluate (snd kdr) env
341 |                                  (lambda (x)
342 |                                    (k (define-var (fst kdr) x env))))
343 |                      (if (eq? kar 'set!) ; (set! v e)
344 |                          (evaluate (snd kdr) env
345 |                                    (lambda (x)
346 |                                      (k (set-var (look-for-pair (fst kdr) env)
347 |                                                  x))))
348 |                        (if (eq? kar '$Intrinsic)
349 |                            (k exp)
350 |                          (if (eq? kar '$Continuation)
351 |                              (k exp)
352 |                            (if (eq? kar '$Closure)
353 |                                (k exp)
354 |                              (evaluate kar env
355 |                                        (lambda (fun)
356 |                                          (evlis kdr env
357 |                                                 (lambda (arg)
358 |                                                   (apply-fun fun arg k)
359 |                                                   ))))))))))))))
360 |          (car exp)                      ; = kar
361 |          (cdr exp))                     ; = kdr
362 |       (if (symbol? exp)
363 |           (k ((look-for-pair exp env) 'cdr))
364 |         (k exp)))))                     ; as a number, #t, #f etc.
365 | 
366 | ;; Apply a function to arguments with a continuation.
367 | (define apply-fun
368 |   (lambda (fun arg k)
369 |     (if (eq? fun 'call/cc)
370 |         (apply-fun (fst arg) (list (cons '$Continuation k)) k)
371 |       (if (eq? fun 'apply)
372 |           (apply-fun (fst arg) (snd arg) k)
373 |         (if (pair? fun)
374 |             ((lambda (kar kdr)
375 |                (if (eq? kar '$Intrinsic)
376 |                    (k (kdr arg))
377 |                  (if (eq? kar '$Continuation)
378 |                      (kdr (fst arg))
379 |                    (if (eq? kar '$Closure)
380 |                        (eval-sequentially
381 |                         (snd kdr)       ; body
382 |                         (_ (_ '() '())  ; frame marker
383 |                            (prepend-defs-to-env (fst kdr) ; params
384 |                                                 arg
385 |                                                 (trd kdr))) ; env
386 |                         k)
387 |                      (_error "unknown functional pair" fun)))))
388 |              (car fun)
389 |              (cdr fun))
390 |           (_error "unknown function" fun))))))
391 | 
392 | ;; Evaluate each element of list sequentially to yield the last result.
393 | (define eval-sequentially
394 |   (lambda (explist env k)
395 |     (evaluate (car explist) env
396 |               (if (null? (cdr explist))
397 |                   k
398 |                 (lambda (x) (eval-sequentially (cdr explist) env k))))))
399 | 
400 | ;; Evaluate each element of list to construct a new list of the results.
401 | ;; (evlis '((* 1 2) (* 3 4)) Global-Env list) => (list '(2 12)) => ((2 12))
402 | (define evlis
403 |   (lambda (arg env k)
404 |     (if (null? arg)
405 |         (k '())
406 |       (evaluate (car arg) env
407 |                 (lambda (head)
408 |                   (evlis (cdr arg) env
409 |                          (lambda (tail)
410 |                            (k (cons head tail)))))))))
411 | 
412 | ;; env = (_ (_ '() '()) x); (deinfe-var 'a 1 env) => None;
413 | ;; env = (_ (_ '() '()) (_ (_ a 1) x))
414 | (define define-var
415 |   (lambda (v e env)
416 |     (if (null? ((env 'car) 'car))       ; Check for the frame marker.
417 |         (env (list (_ (_ v e)
418 |                       (env 'cdr))))
419 |       (_error "illegal frame marker" ((env 'car) 'car)))))
420 | 
421 | ;; x = (_ a 1); (set-var x 2) => None; x = (_ a 2)
422 | (define set-var
423 |   (lambda (pair e)
424 |     (pair (list e))))
425 | 
426 | ;; (look-for-pair 'b (_ (_ a 1) (_ (_ b 2) (_ (_ c 3) 'nil)))) => (_ b 2)
427 | (define look-for-pair
428 |   (lambda (key alist)
429 |     (if (null? alist)
430 |         (_error "not found" key)
431 |       (if (eq? key ((alist 'car) 'car))
432 |           (alist 'car)
433 |         (look-for-pair key (alist 'cdr))))))
434 | 
435 | ;; (prepend-defs-to-env '(a b) '(1 2) x) => (_ (_ a 1) (_ (_ b 1) x))
436 | (define prepend-defs-to-env
437 |   (lambda (keys data env)
438 |     (if (null? keys)
439 |         env
440 |       (_ (_ (car keys) (car data))
441 |          (prepend-defs-to-env (cdr keys) (cdr data) env)))))
442 | 
443 | ;; Evaluate an expression in the global environment.
444 | (define global-eval
445 |   (lambda (exp)
446 |     (call/cc (lambda (k)
447 |                (set! exit-with k)
448 |                (evaluate exp Global-Env (lambda (x) x))))))
449 | 
450 | ;; Repeat read-eval-print until End-of-File.
451 | (define read-eval-print-loop
452 |   (lambda ()
453 |     ((lambda (input)
454 |        (if (not (eof-object? input))
455 |            (begin
456 |              ((lambda (result)
457 |                 (if (not (eq? result None))
458 |                     (begin
459 |                       (display "=> ") (display result)
460 |                       (newline))))
461 |               (global-eval input))
462 |              (read-eval-print-loop))))
463 |      (read))))
464 | 
465 | ;; (read-eval-print-loop)
466 | (global-eval '(begin
467 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
468 | 
469 | ;; Intrinsic:    ($Intrinsic . function)
470 | ;; Continuation: ($Continuation . function)
471 | ;; Closure:      ($Closure params body env)
472 | 
473 | (define fst car)
474 | (define snd (lambda (x) (car (cdr x))))
475 | (define trd (lambda (x) (car (cdr (cdr x)))))
476 | (define None (set! fst fst))
477 | (define exit-with #f)               ; to be set at global-eval
478 | 
479 | (define _error
480 |   (lambda (reason arg)
481 |     (display "Error: ") (display reason) (display ": ") (display arg)
482 |     (newline)
483 |     (exit-with None)))
484 | 
485 | ;; (_ CAR_ CDR_) returns a mutable cell to construct environments.
486 | ;; (define x (_ 'a 'b))
487 | ;; (x 'car) => a
488 | ;; (x 'cdr) => b
489 | ;; (x '(c)) => None; (x 'cdr) = c
490 | (define _
491 |   (lambda (CAR_ CDR_)
492 |     (lambda (op)
493 |       (if (eq? op 'car)
494 |           CAR_
495 |         (if (eq? op 'cdr)
496 |             CDR_
497 |           (if (pair? op)
498 |               (set! CDR_ (car op))
499 |             (_error "unknown op" op)))))))
500 | 
501 | ;; Return a list of keys of the global environment.
502 | (define globals
503 |   (lambda (loop)
504 |     (set! loop (lambda (env result)
505 |                  (if (null? env)
506 |                      result
507 |                    (loop (env 'cdr)
508 |                          (cons ((env 'car) 'car)
509 |                                result)))))
510 |     (loop (Global-Env 'cdr) '()))) ; Take cdr to skip the frame marker.
511 | 
512 | (define _i
513 |   (lambda (name fun)
514 |     (_ name (cons '$Intrinsic fun))))
515 | 
516 | (define Global-Env
517 |   (_ (_i '< (lambda (x) (< (fst x) (snd x))))
518 |      (_ (_i '= (lambda (x) (= (fst x) (snd x))))
519 |         (_ (_i 'number? (lambda (x) (number? (fst x))))
520 |            (_ (_i 'error (lambda (x) (_error (fst x) (snd x)))) ; cf. SRFI-23
521 |               (_ (_i 'globals globals)
522 |                  '()))))))
523 | 
524 | (set! Global-Env
525 |       (_ (_i 'display (lambda (x) (display (fst x))))
526 |          (_ (_i 'newline (lambda (x) (newline)))
527 |             (_ (_i 'read (lambda (x) (read)))
528 |                (_ (_i 'eof-object? (lambda (x) (eof-object? (fst x))))
529 |                   (_ (_i 'symbol? (lambda (x) (symbol? (fst x))))
530 |                      (_ (_ 'call/cc 'call/cc)
531 |                         (_ (_ 'apply 'apply)
532 |                            (_ (_i '+ (lambda (x) (+ (fst x) (snd x))))
533 |                               (_ (_i '- (lambda (x) (- (fst x) (snd x))))
534 |                                  (_ (_i '* (lambda (x) (* (fst x) (snd x))))
535 |                                     Global-Env)))))))))))
536 | 
537 | (set! Global-Env
538 |       (_ (_ '() '())                    ; frame marker
539 |          (_ (_i 'car (lambda (x) (car (fst x))))
540 |             (_ (_i 'cdr (lambda (x) (cdr (fst x))))
541 |                (_ (_i 'cons (lambda (x) (cons (fst x) (snd x))))
542 |                   (_ (_i 'eq? (lambda (x) (eq? (fst x) (snd x))))
543 |                      (_ (_i 'pair? (lambda (x) (pair? (fst x))))
544 |                         (_ (_i 'null? (lambda (x) (null? (fst x))))
545 |                            (_ (_i 'not (lambda (x) (not (fst x))))
546 |                               (_ (_i 'list (lambda (x) x))
547 |                                  Global-Env))))))))))
548 | 
549 | ;; Evaluate an expression with an environment and a continuation.
550 | (define evaluate
551 |   (lambda (exp env k)
552 |     (if (pair? exp)
553 |         ((lambda (kar kdr)
554 |            (if (eq? kar 'quote)         ; (quote e)
555 |                (k (fst kdr))
556 |              (if (eq? kar 'if)          ; (if e1 e2) or (if e1 e2 e3)
557 |                  (if (null? (cdr (cdr kdr)))
558 |                      (evaluate (fst kdr) env
559 |                                (lambda (x)
560 |                                  (if x
561 |                                      (evaluate (snd kdr) env k)
562 |                                    (evaluate None env k))))
563 |                    (evaluate (fst kdr) env
564 |                              (lambda (x)
565 |                                (if x
566 |                                    (evaluate (snd kdr) env k)
567 |                                  (evaluate (trd kdr) env k)))))
568 |                (if (eq? kar 'begin)     ; (begin e...)
569 |                    (eval-sequentially kdr env k)
570 |                  (if (eq? kar 'lambda)  ; (lambda (v...) e...)
571 |                      (k (list '$Closure (car kdr) (cdr kdr) env))
572 |                    (if (eq? kar 'define) ; (define v e)
573 |                        (evaluate (snd kdr) env
574 |                                  (lambda (x)
575 |                                    (k (define-var (fst kdr) x env))))
576 |                      (if (eq? kar 'set!) ; (set! v e)
577 |                          (evaluate (snd kdr) env
578 |                                    (lambda (x)
579 |                                      (k (set-var (look-for-pair (fst kdr) env)
580 |                                                  x))))
581 |                        (if (eq? kar '$Intrinsic)
582 |                            (k exp)
583 |                          (if (eq? kar '$Continuation)
584 |                              (k exp)
585 |                            (if (eq? kar '$Closure)
586 |                                (k exp)
587 |                              (evaluate kar env
588 |                                        (lambda (fun)
589 |                                          (evlis kdr env
590 |                                                 (lambda (arg)
591 |                                                   (apply-fun fun arg k)
592 |                                                   ))))))))))))))
593 |          (car exp)                      ; = kar
594 |          (cdr exp))                     ; = kdr
595 |       (if (symbol? exp)
596 |           (k ((look-for-pair exp env) 'cdr))
597 |         (k exp)))))                     ; as a number, #t, #f etc.
598 | 
599 | ;; Apply a function to arguments with a continuation.
600 | (define apply-fun
601 |   (lambda (fun arg k)
602 |     (if (eq? fun 'call/cc)
603 |         (apply-fun (fst arg) (list (cons '$Continuation k)) k)
604 |       (if (eq? fun 'apply)
605 |           (apply-fun (fst arg) (snd arg) k)
606 |         (if (pair? fun)
607 |             ((lambda (kar kdr)
608 |                (if (eq? kar '$Intrinsic)
609 |                    (k (kdr arg))
610 |                  (if (eq? kar '$Continuation)
611 |                      (kdr (fst arg))
612 |                    (if (eq? kar '$Closure)
613 |                        (eval-sequentially
614 |                         (snd kdr)       ; body
615 |                         (_ (_ '() '())  ; frame marker
616 |                            (prepend-defs-to-env (fst kdr) ; params
617 |                                                 arg
618 |                                                 (trd kdr))) ; env
619 |                         k)
620 |                      (_error "unknown functional pair" fun)))))
621 |              (car fun)
622 |              (cdr fun))
623 |           (_error "unknown function" fun))))))
624 | 
625 | ;; Evaluate each element of list sequentially to yield the last result.
626 | (define eval-sequentially
627 |   (lambda (explist env k)
628 |     (evaluate (car explist) env
629 |               (if (null? (cdr explist))
630 |                   k
631 |                 (lambda (x) (eval-sequentially (cdr explist) env k))))))
632 | 
633 | ;; Evaluate each element of list to construct a new list of the results.
634 | ;; (evlis '((* 1 2) (* 3 4)) Global-Env list) => (list '(2 12)) => ((2 12))
635 | (define evlis
636 |   (lambda (arg env k)
637 |     (if (null? arg)
638 |         (k '())
639 |       (evaluate (car arg) env
640 |                 (lambda (head)
641 |                   (evlis (cdr arg) env
642 |                          (lambda (tail)
643 |                            (k (cons head tail)))))))))
644 | 
645 | ;; env = (_ (_ '() '()) x); (deinfe-var 'a 1 env) => None;
646 | ;; env = (_ (_ '() '()) (_ (_ a 1) x))
647 | (define define-var
648 |   (lambda (v e env)
649 |     (if (null? ((env 'car) 'car))       ; Check for the frame marker.
650 |         (env (list (_ (_ v e)
651 |                       (env 'cdr))))
652 |       (_error "illegal frame marker" ((env 'car) 'car)))))
653 | 
654 | ;; x = (_ a 1); (set-var x 2) => None; x = (_ a 2)
655 | (define set-var
656 |   (lambda (pair e)
657 |     (pair (list e))))
658 | 
659 | ;; (look-for-pair 'b (_ (_ a 1) (_ (_ b 2) (_ (_ c 3) 'nil)))) => (_ b 2)
660 | (define look-for-pair
661 |   (lambda (key alist)
662 |     (if (null? alist)
663 |         (_error "not found" key)
664 |       (if (eq? key ((alist 'car) 'car))
665 |           (alist 'car)
666 |         (look-for-pair key (alist 'cdr))))))
667 | 
668 | ;; (prepend-defs-to-env '(a b) '(1 2) x) => (_ (_ a 1) (_ (_ b 1) x))
669 | (define prepend-defs-to-env
670 |   (lambda (keys data env)
671 |     (if (null? keys)
672 |         env
673 |       (_ (_ (car keys) (car data))
674 |          (prepend-defs-to-env (cdr keys) (cdr data) env)))))
675 | 
676 | ;; Evaluate an expression in the global environment.
677 | (define global-eval
678 |   (lambda (exp)
679 |     (call/cc (lambda (k)
680 |                (set! exit-with k)
681 |                (evaluate exp Global-Env (lambda (x) x))))))
682 | 
683 | ;; Repeat read-eval-print until End-of-File.
684 | (define read-eval-print-loop
685 |   (lambda ()
686 |     ((lambda (input)
687 |        (if (not (eof-object? input))
688 |            (begin
689 |              ((lambda (result)
690 |                 (if (not (eq? result None))
691 |                     (begin
692 |                       (display "=> ") (display result)
693 |                       (newline))))
694 |               (global-eval input))
695 |              (read-eval-print-loop))))
696 |      (read))))
697 | 
698 | (read-eval-print-loop)
699 | ))
700 | ))
701 | 


--------------------------------------------------------------------------------
/tower/scm-scm.scm:
--------------------------------------------------------------------------------
  1 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
  2 | 
  3 | ;; Intrinsic:    ($Intrinsic . function)
  4 | ;; Continuation: ($Continuation . function)
  5 | ;; Closure:      ($Closure params body env)
  6 | 
  7 | (define fst car)
  8 | (define snd (lambda (x) (car (cdr x))))
  9 | (define trd (lambda (x) (car (cdr (cdr x)))))
 10 | (define None (set! fst fst))
 11 | (define exit-with #f)               ; to be set at global-eval
 12 | 
 13 | (define _error
 14 |   (lambda (reason arg)
 15 |     (display "Error: ") (display reason) (display ": ") (display arg)
 16 |     (newline)
 17 |     (exit-with None)))
 18 | 
 19 | ;; (_ CAR_ CDR_) returns a mutable cell to construct environments.
 20 | ;; (define x (_ 'a 'b))
 21 | ;; (x 'car) => a
 22 | ;; (x 'cdr) => b
 23 | ;; (x '(c)) => None; (x 'cdr) = c
 24 | (define _
 25 |   (lambda (CAR_ CDR_)
 26 |     (lambda (op)
 27 |       (if (eq? op 'car)
 28 |           CAR_
 29 |         (if (eq? op 'cdr)
 30 |             CDR_
 31 |           (if (pair? op)
 32 |               (set! CDR_ (car op))
 33 |             (_error "unknown op" op)))))))
 34 | 
 35 | ;; Return a list of keys of the global environment.
 36 | (define globals
 37 |   (lambda (loop)
 38 |     (set! loop (lambda (env result)
 39 |                  (if (null? env)
 40 |                      result
 41 |                    (loop (env 'cdr)
 42 |                          (cons ((env 'car) 'car)
 43 |                                result)))))
 44 |     (loop (Global-Env 'cdr) '()))) ; Take cdr to skip the frame marker.
 45 | 
 46 | (define _i
 47 |   (lambda (name fun)
 48 |     (_ name (cons '$Intrinsic fun))))
 49 | 
 50 | (define Global-Env
 51 |   (_ (_i '< (lambda (x) (< (fst x) (snd x))))
 52 |      (_ (_i '= (lambda (x) (= (fst x) (snd x))))
 53 |         (_ (_i 'number? (lambda (x) (number? (fst x))))
 54 |            (_ (_i 'error (lambda (x) (_error (fst x) (snd x)))) ; cf. SRFI-23
 55 |               (_ (_i 'globals globals)
 56 |                  '()))))))
 57 | 
 58 | (set! Global-Env
 59 |       (_ (_i 'display (lambda (x) (display (fst x))))
 60 |          (_ (_i 'newline (lambda (x) (newline)))
 61 |             (_ (_i 'read (lambda (x) (read)))
 62 |                (_ (_i 'eof-object? (lambda (x) (eof-object? (fst x))))
 63 |                   (_ (_i 'symbol? (lambda (x) (symbol? (fst x))))
 64 |                      (_ (_ 'call/cc 'call/cc)
 65 |                         (_ (_ 'apply 'apply)
 66 |                            (_ (_i '+ (lambda (x) (+ (fst x) (snd x))))
 67 |                               (_ (_i '- (lambda (x) (- (fst x) (snd x))))
 68 |                                  (_ (_i '* (lambda (x) (* (fst x) (snd x))))
 69 |                                     Global-Env)))))))))))
 70 | 
 71 | (set! Global-Env
 72 |       (_ (_ '() '())                    ; frame marker
 73 |          (_ (_i 'car (lambda (x) (car (fst x))))
 74 |             (_ (_i 'cdr (lambda (x) (cdr (fst x))))
 75 |                (_ (_i 'cons (lambda (x) (cons (fst x) (snd x))))
 76 |                   (_ (_i 'eq? (lambda (x) (eq? (fst x) (snd x))))
 77 |                      (_ (_i 'pair? (lambda (x) (pair? (fst x))))
 78 |                         (_ (_i 'null? (lambda (x) (null? (fst x))))
 79 |                            (_ (_i 'not (lambda (x) (not (fst x))))
 80 |                               (_ (_i 'list (lambda (x) x))
 81 |                                  Global-Env))))))))))
 82 | 
 83 | ;; Evaluate an expression with an environment and a continuation.
 84 | (define evaluate
 85 |   (lambda (exp env k)
 86 |     (if (pair? exp)
 87 |         ((lambda (kar kdr)
 88 |            (if (eq? kar 'quote)         ; (quote e)
 89 |                (k (fst kdr))
 90 |              (if (eq? kar 'if)          ; (if e1 e2) or (if e1 e2 e3)
 91 |                  (if (null? (cdr (cdr kdr)))
 92 |                      (evaluate (fst kdr) env
 93 |                                (lambda (x)
 94 |                                  (if x
 95 |                                      (evaluate (snd kdr) env k)
 96 |                                    (evaluate None env k))))
 97 |                    (evaluate (fst kdr) env
 98 |                              (lambda (x)
 99 |                                (if x
100 |                                    (evaluate (snd kdr) env k)
101 |                                  (evaluate (trd kdr) env k)))))
102 |                (if (eq? kar 'begin)     ; (begin e...)
103 |                    (eval-sequentially kdr env k)
104 |                  (if (eq? kar 'lambda)  ; (lambda (v...) e...)
105 |                      (k (list '$Closure (car kdr) (cdr kdr) env))
106 |                    (if (eq? kar 'define) ; (define v e)
107 |                        (evaluate (snd kdr) env
108 |                                  (lambda (x)
109 |                                    (k (define-var (fst kdr) x env))))
110 |                      (if (eq? kar 'set!) ; (set! v e)
111 |                          (evaluate (snd kdr) env
112 |                                    (lambda (x)
113 |                                      (k (set-var (look-for-pair (fst kdr) env)
114 |                                                  x))))
115 |                        (if (eq? kar '$Intrinsic)
116 |                            (k exp)
117 |                          (if (eq? kar '$Continuation)
118 |                              (k exp)
119 |                            (if (eq? kar '$Closure)
120 |                                (k exp)
121 |                              (evaluate kar env
122 |                                        (lambda (fun)
123 |                                          (evlis kdr env
124 |                                                 (lambda (arg)
125 |                                                   (apply-fun fun arg k)
126 |                                                   ))))))))))))))
127 |          (car exp)                      ; = kar
128 |          (cdr exp))                     ; = kdr
129 |       (if (symbol? exp)
130 |           (k ((look-for-pair exp env) 'cdr))
131 |         (k exp)))))                     ; as a number, #t, #f etc.
132 | 
133 | ;; Apply a function to arguments with a continuation.
134 | (define apply-fun
135 |   (lambda (fun arg k)
136 |     (if (eq? fun 'call/cc)
137 |         (apply-fun (fst arg) (list (cons '$Continuation k)) k)
138 |       (if (eq? fun 'apply)
139 |           (apply-fun (fst arg) (snd arg) k)
140 |         (if (pair? fun)
141 |             ((lambda (kar kdr)
142 |                (if (eq? kar '$Intrinsic)
143 |                    (k (kdr arg))
144 |                  (if (eq? kar '$Continuation)
145 |                      (kdr (fst arg))
146 |                    (if (eq? kar '$Closure)
147 |                        (eval-sequentially
148 |                         (snd kdr)       ; body
149 |                         (_ (_ '() '())  ; frame marker
150 |                            (prepend-defs-to-env (fst kdr) ; params
151 |                                                 arg
152 |                                                 (trd kdr))) ; env
153 |                         k)
154 |                      (_error "unknown functional pair" fun)))))
155 |              (car fun)
156 |              (cdr fun))
157 |           (_error "unknown function" fun))))))
158 | 
159 | ;; Evaluate each element of list sequentially to yield the last result.
160 | (define eval-sequentially
161 |   (lambda (explist env k)
162 |     (evaluate (car explist) env
163 |               (if (null? (cdr explist))
164 |                   k
165 |                 (lambda (x) (eval-sequentially (cdr explist) env k))))))
166 | 
167 | ;; Evaluate each element of list to construct a new list of the results.
168 | ;; (evlis '((* 1 2) (* 3 4)) Global-Env list) => (list '(2 12)) => ((2 12))
169 | (define evlis
170 |   (lambda (arg env k)
171 |     (if (null? arg)
172 |         (k '())
173 |       (evaluate (car arg) env
174 |                 (lambda (head)
175 |                   (evlis (cdr arg) env
176 |                          (lambda (tail)
177 |                            (k (cons head tail)))))))))
178 | 
179 | ;; env = (_ (_ '() '()) x); (deinfe-var 'a 1 env) => None;
180 | ;; env = (_ (_ '() '()) (_ (_ a 1) x))
181 | (define define-var
182 |   (lambda (v e env)
183 |     (if (null? ((env 'car) 'car))       ; Check for the frame marker.
184 |         (env (list (_ (_ v e)
185 |                       (env 'cdr))))
186 |       (_error "illegal frame marker" ((env 'car) 'car)))))
187 | 
188 | ;; x = (_ a 1); (set-var x 2) => None; x = (_ a 2)
189 | (define set-var
190 |   (lambda (pair e)
191 |     (pair (list e))))
192 | 
193 | ;; (look-for-pair 'b (_ (_ a 1) (_ (_ b 2) (_ (_ c 3) 'nil)))) => (_ b 2)
194 | (define look-for-pair
195 |   (lambda (key alist)
196 |     (if (null? alist)
197 |         (_error "not found" key)
198 |       (if (eq? key ((alist 'car) 'car))
199 |           (alist 'car)
200 |         (look-for-pair key (alist 'cdr))))))
201 | 
202 | ;; (prepend-defs-to-env '(a b) '(1 2) x) => (_ (_ a 1) (_ (_ b 1) x))
203 | (define prepend-defs-to-env
204 |   (lambda (keys data env)
205 |     (if (null? keys)
206 |         env
207 |       (_ (_ (car keys) (car data))
208 |          (prepend-defs-to-env (cdr keys) (cdr data) env)))))
209 | 
210 | ;; Evaluate an expression in the global environment.
211 | (define global-eval
212 |   (lambda (exp)
213 |     (call/cc (lambda (k)
214 |                (set! exit-with k)
215 |                (evaluate exp Global-Env (lambda (x) x))))))
216 | 
217 | ;; Repeat read-eval-print until End-of-File.
218 | (define read-eval-print-loop
219 |   (lambda ()
220 |     ((lambda (input)
221 |        (if (not (eof-object? input))
222 |            (begin
223 |              ((lambda (result)
224 |                 (if (not (eq? result None))
225 |                     (begin
226 |                       (display "=> ") (display result)
227 |                       (newline))))
228 |               (global-eval input))
229 |              (read-eval-print-loop))))
230 |      (read))))
231 | 
232 | ;; (read-eval-print-loop)
233 | (global-eval '(begin
234 | ;; A meta-circular little Scheme v1.3 R02.04.12 by SUZUKI Hisao
235 | 
236 | ;; Intrinsic:    ($Intrinsic . function)
237 | ;; Continuation: ($Continuation . function)
238 | ;; Closure:      ($Closure params body env)
239 | 
240 | (define fst car)
241 | (define snd (lambda (x) (car (cdr x))))
242 | (define trd (lambda (x) (car (cdr (cdr x)))))
243 | (define None (set! fst fst))
244 | (define exit-with #f)               ; to be set at global-eval
245 | 
246 | (define _error
247 |   (lambda (reason arg)
248 |     (display "Error: ") (display reason) (display ": ") (display arg)
249 |     (newline)
250 |     (exit-with None)))
251 | 
252 | ;; (_ CAR_ CDR_) returns a mutable cell to construct environments.
253 | ;; (define x (_ 'a 'b))
254 | ;; (x 'car) => a
255 | ;; (x 'cdr) => b
256 | ;; (x '(c)) => None; (x 'cdr) = c
257 | (define _
258 |   (lambda (CAR_ CDR_)
259 |     (lambda (op)
260 |       (if (eq? op 'car)
261 |           CAR_
262 |         (if (eq? op 'cdr)
263 |             CDR_
264 |           (if (pair? op)
265 |               (set! CDR_ (car op))
266 |             (_error "unknown op" op)))))))
267 | 
268 | ;; Return a list of keys of the global environment.
269 | (define globals
270 |   (lambda (loop)
271 |     (set! loop (lambda (env result)
272 |                  (if (null? env)
273 |                      result
274 |                    (loop (env 'cdr)
275 |                          (cons ((env 'car) 'car)
276 |                                result)))))
277 |     (loop (Global-Env 'cdr) '()))) ; Take cdr to skip the frame marker.
278 | 
279 | (define _i
280 |   (lambda (name fun)
281 |     (_ name (cons '$Intrinsic fun))))
282 | 
283 | (define Global-Env
284 |   (_ (_i '< (lambda (x) (< (fst x) (snd x))))
285 |      (_ (_i '= (lambda (x) (= (fst x) (snd x))))
286 |         (_ (_i 'number? (lambda (x) (number? (fst x))))
287 |            (_ (_i 'error (lambda (x) (_error (fst x) (snd x)))) ; cf. SRFI-23
288 |               (_ (_i 'globals globals)
289 |                  '()))))))
290 | 
291 | (set! Global-Env
292 |       (_ (_i 'display (lambda (x) (display (fst x))))
293 |          (_ (_i 'newline (lambda (x) (newline)))
294 |             (_ (_i 'read (lambda (x) (read)))
295 |                (_ (_i 'eof-object? (lambda (x) (eof-object? (fst x))))
296 |                   (_ (_i 'symbol? (lambda (x) (symbol? (fst x))))
297 |                      (_ (_ 'call/cc 'call/cc)
298 |                         (_ (_ 'apply 'apply)
299 |                            (_ (_i '+ (lambda (x) (+ (fst x) (snd x))))
300 |                               (_ (_i '- (lambda (x) (- (fst x) (snd x))))
301 |                                  (_ (_i '* (lambda (x) (* (fst x) (snd x))))
302 |                                     Global-Env)))))))))))
303 | 
304 | (set! Global-Env
305 |       (_ (_ '() '())                    ; frame marker
306 |          (_ (_i 'car (lambda (x) (car (fst x))))
307 |             (_ (_i 'cdr (lambda (x) (cdr (fst x))))
308 |                (_ (_i 'cons (lambda (x) (cons (fst x) (snd x))))
309 |                   (_ (_i 'eq? (lambda (x) (eq? (fst x) (snd x))))
310 |                      (_ (_i 'pair? (lambda (x) (pair? (fst x))))
311 |                         (_ (_i 'null? (lambda (x) (null? (fst x))))
312 |                            (_ (_i 'not (lambda (x) (not (fst x))))
313 |                               (_ (_i 'list (lambda (x) x))
314 |                                  Global-Env))))))))))
315 | 
316 | ;; Evaluate an expression with an environment and a continuation.
317 | (define evaluate
318 |   (lambda (exp env k)
319 |     (if (pair? exp)
320 |         ((lambda (kar kdr)
321 |            (if (eq? kar 'quote)         ; (quote e)
322 |                (k (fst kdr))
323 |              (if (eq? kar 'if)          ; (if e1 e2) or (if e1 e2 e3)
324 |                  (if (null? (cdr (cdr kdr)))
325 |                      (evaluate (fst kdr) env
326 |                                (lambda (x)
327 |                                  (if x
328 |                                      (evaluate (snd kdr) env k)
329 |                                    (evaluate None env k))))
330 |                    (evaluate (fst kdr) env
331 |                              (lambda (x)
332 |                                (if x
333 |                                    (evaluate (snd kdr) env k)
334 |                                  (evaluate (trd kdr) env k)))))
335 |                (if (eq? kar 'begin)     ; (begin e...)
336 |                    (eval-sequentially kdr env k)
337 |                  (if (eq? kar 'lambda)  ; (lambda (v...) e...)
338 |                      (k (list '$Closure (car kdr) (cdr kdr) env))
339 |                    (if (eq? kar 'define) ; (define v e)
340 |                        (evaluate (snd kdr) env
341 |                                  (lambda (x)
342 |                                    (k (define-var (fst kdr) x env))))
343 |                      (if (eq? kar 'set!) ; (set! v e)
344 |                          (evaluate (snd kdr) env
345 |                                    (lambda (x)
346 |                                      (k (set-var (look-for-pair (fst kdr) env)
347 |                                                  x))))
348 |                        (if (eq? kar '$Intrinsic)
349 |                            (k exp)
350 |                          (if (eq? kar '$Continuation)
351 |                              (k exp)
352 |                            (if (eq? kar '$Closure)
353 |                                (k exp)
354 |                              (evaluate kar env
355 |                                        (lambda (fun)
356 |                                          (evlis kdr env
357 |                                                 (lambda (arg)
358 |                                                   (apply-fun fun arg k)
359 |                                                   ))))))))))))))
360 |          (car exp)                      ; = kar
361 |          (cdr exp))                     ; = kdr
362 |       (if (symbol? exp)
363 |           (k ((look-for-pair exp env) 'cdr))
364 |         (k exp)))))                     ; as a number, #t, #f etc.
365 | 
366 | ;; Apply a function to arguments with a continuation.
367 | (define apply-fun
368 |   (lambda (fun arg k)
369 |     (if (eq? fun 'call/cc)
370 |         (apply-fun (fst arg) (list (cons '$Continuation k)) k)
371 |       (if (eq? fun 'apply)
372 |           (apply-fun (fst arg) (snd arg) k)
373 |         (if (pair? fun)
374 |             ((lambda (kar kdr)
375 |                (if (eq? kar '$Intrinsic)
376 |                    (k (kdr arg))
377 |                  (if (eq? kar '$Continuation)
378 |                      (kdr (fst arg))
379 |                    (if (eq? kar '$Closure)
380 |                        (eval-sequentially
381 |                         (snd kdr)       ; body
382 |                         (_ (_ '() '())  ; frame marker
383 |                            (prepend-defs-to-env (fst kdr) ; params
384 |                                                 arg
385 |                                                 (trd kdr))) ; env
386 |                         k)
387 |                      (_error "unknown functional pair" fun)))))
388 |              (car fun)
389 |              (cdr fun))
390 |           (_error "unknown function" fun))))))
391 | 
392 | ;; Evaluate each element of list sequentially to yield the last result.
393 | (define eval-sequentially
394 |   (lambda (explist env k)
395 |     (evaluate (car explist) env
396 |               (if (null? (cdr explist))
397 |                   k
398 |                 (lambda (x) (eval-sequentially (cdr explist) env k))))))
399 | 
400 | ;; Evaluate each element of list to construct a new list of the results.
401 | ;; (evlis '((* 1 2) (* 3 4)) Global-Env list) => (list '(2 12)) => ((2 12))
402 | (define evlis
403 |   (lambda (arg env k)
404 |     (if (null? arg)
405 |         (k '())
406 |       (evaluate (car arg) env
407 |                 (lambda (head)
408 |                   (evlis (cdr arg) env
409 |                          (lambda (tail)
410 |                            (k (cons head tail)))))))))
411 | 
412 | ;; env = (_ (_ '() '()) x); (deinfe-var 'a 1 env) => None;
413 | ;; env = (_ (_ '() '()) (_ (_ a 1) x))
414 | (define define-var
415 |   (lambda (v e env)
416 |     (if (null? ((env 'car) 'car))       ; Check for the frame marker.
417 |         (env (list (_ (_ v e)
418 |                       (env 'cdr))))
419 |       (_error "illegal frame marker" ((env 'car) 'car)))))
420 | 
421 | ;; x = (_ a 1); (set-var x 2) => None; x = (_ a 2)
422 | (define set-var
423 |   (lambda (pair e)
424 |     (pair (list e))))
425 | 
426 | ;; (look-for-pair 'b (_ (_ a 1) (_ (_ b 2) (_ (_ c 3) 'nil)))) => (_ b 2)
427 | (define look-for-pair
428 |   (lambda (key alist)
429 |     (if (null? alist)
430 |         (_error "not found" key)
431 |       (if (eq? key ((alist 'car) 'car))
432 |           (alist 'car)
433 |         (look-for-pair key (alist 'cdr))))))
434 | 
435 | ;; (prepend-defs-to-env '(a b) '(1 2) x) => (_ (_ a 1) (_ (_ b 1) x))
436 | (define prepend-defs-to-env
437 |   (lambda (keys data env)
438 |     (if (null? keys)
439 |         env
440 |       (_ (_ (car keys) (car data))
441 |          (prepend-defs-to-env (cdr keys) (cdr data) env)))))
442 | 
443 | ;; Evaluate an expression in the global environment.
444 | (define global-eval
445 |   (lambda (exp)
446 |     (call/cc (lambda (k)
447 |                (set! exit-with k)
448 |                (evaluate exp Global-Env (lambda (x) x))))))
449 | 
450 | ;; Repeat read-eval-print until End-of-File.
451 | (define read-eval-print-loop
452 |   (lambda ()
453 |     ((lambda (input)
454 |        (if (not (eof-object? input))
455 |            (begin
456 |              ((lambda (result)
457 |                 (if (not (eq? result None))
458 |                     (begin
459 |                       (display "=> ") (display result)
460 |                       (newline))))
461 |               (global-eval input))
462 |              (read-eval-print-loop))))
463 |      (read))))
464 | 
465 | (read-eval-print-loop)
466 | ))
467 | 


--------------------------------------------------------------------------------