/
Lisp.fif
385 lines (380 loc) · 12.8 KB
/
Lisp.fif
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
library Lisp // tiny Lisp (or rather Scheme) interpreter
"Lists.fif" include
variable lisp-dict
{ hole dup 1 { @ execute } does create } : recursive
{ atom>$ +" undefined" abort } : report-not-found
// a l -- d -1 or a 0 Look up definition d of atom a in dictionary l
{ { dup null? { drop false true }
{ uncons -rot unpair -rot over eq?
{ drop nip true true } { nip swap false } cond
} cond
} until
} : lookup-in
// a dict -- def
{ lookup-in ' report-not-found ifnot } : lookup-or-fail
{ lisp-dict @ lookup-or-fail } : lisp-dict-lookup
// a d -- Defines a with definition d in dictionary lisp-dict
{ pair lisp-dict @ cons lisp-dict ! } : lisp-dict-int-define
{ box lisp-dict-int-define } : lisp-dict-define
// a d -- Defines new a with defininition d
{ over lisp-dict @ lookup-in { 2drop atom>$ +" already defined" abort }
{ drop lisp-dict-int-define } cond
} : lisp-dict-int-define-new
{ box lisp-dict-int-define-new } : lisp-dict-define-new
// a e -- Defines a with executable definition given by e
{ single lisp-dict-define-new } : lisp-dict-define-exec
// expr ctx def -- val
{ dup first execute } : run-definition
// expr ctx -- val
recursive lisp-ctx-eval {
over tuple?
{ over first over lisp-ctx-eval run-definition }
{ over atom? { lookup-or-fail @ } { drop } cond }
cond
} swap !
// exp -- value
{ lisp-dict @ lisp-ctx-eval } : lisp-eval
// (exprs) ctx -- (vals)
recursive lisp-ctx-eval-list
{ over null? { drop } {
swap uncons -rot over lisp-ctx-eval -rot lisp-ctx-eval-list cons
} cond
} swap !
// (exprs) ctx -- val
{ null rot {
dup null? { drop nip true } {
nip uncons swap 2 pick lisp-ctx-eval swap false
} cond } until
} : lisp-ctx-eval-list-last
// l c -- (args)
{ swap uncons nip swap lisp-ctx-eval-list } : extract-eval-arg-list
{ drop uncons nip } : extract-arg-list
// (x1 .. xn) e n -- x1 .. xn e
{ { swap uncons rot } swap times
swap null? not abort"invalid number of arguments"
} : unpack-list
// l c n e -- v
{ swap 2swap extract-eval-arg-list // e n (args)
-rot unpack-list execute
} : eval-exec-fixed
// l c n e -- v
{ 2 pick pair
swap 2swap extract-arg-list // [e c] n (args)
-rot unpack-list unpair swap execute
} : exec-fixed
// l c e -- v
{ -rot extract-eval-arg-list // e (args)
swap execute
} : eval-exec-list
{ -rot tuck extract-arg-list // e c (args)
swap rot execute
} : exec-list
// e a n --
{ rot 2 { // expr ctx def n e
rot drop eval-exec-fixed } does
lisp-dict-define-exec
} : lisp-fixed-primitive
{ rot 2 { rot drop exec-fixed } does lisp-dict-define-exec
} : lisp-fixed-lazy-primitive
// e a --
{ swap 1 { nip eval-exec-list } does lisp-dict-define-exec
} : lisp-primitive
{ swap 1 { nip exec-list } does lisp-dict-define-exec
} : lisp-lazy-primitive
// Uncomment next line for Fift booleans
// false constant #f true constant #t null constant no-answer
// Uncomment next line for Scheme booleans
`#f constant #f `#t constant #t #f constant no-answer
{ #f eq? } : lisp-false?
{ lisp-false? 0= } : lisp-true?
{ ' #t ' #f cond } : lisp-bool
// temp for defining a lot of primitives
{ bl word atom lisp-primitive } : L:
{ bl word atom swap lisp-dict-define } : L=:
{ bl word atom swap lisp-fixed-primitive } : #L:
{ 0 #L: } : 0L:
{ 1 #L: } : 1L:
{ 2 #L: } : 2L:
// basic primitives
{ sum-list } L: +
{ - } 2L: -
{ dup null? { drop 1 } { ' * foldl-ne } cond } L: *
{ / } 2L: /
{ mod } 2L: modulo
{ abs } 1L: abs
{ ' min foldl-ne } L: min
{ ' max foldl-ne } L: max
{ true ' and foldl } L: integer-and
{ false ' or foldl } L: integer-or
{ 0 ' xor foldl } L: integer-xor
{ not } 1L: integer-not
{ = lisp-bool } 2L: =
{ <> lisp-bool } 2L: <>
{ < lisp-bool } 2L: <
{ <= lisp-bool } 2L: <=
{ > lisp-bool } 2L: >
{ >= lisp-bool } 2L: >=
{ eq? lisp-bool } 2L: eq?
{ eqv? lisp-bool } 2L: eqv?
{ equal? lisp-bool } 2L: equal?
{ cons } 2L: cons
{ car } 1L: car
{ cdr } 1L: cdr
{ cadr } 1L: cadr
{ cddr } 1L: cddr
{ caddr } 1L: caddr
{ cdr cddr } 1L: cdddr
{ concat-list-lists } L: append
{ list-reverse } 1L: reverse
{ list-tail } 2L: list-tail
{ list-ref } 2L: list-ref
{ list-member-eq } 2L: memq
{ list-member-eqv } 2L: memv
{ list-member-equal } 2L: member
{ assq ' #f ifnot } 2L: assq
{ assv ' #f ifnot } 2L: assv
{ assoc ' #f ifnot } 2L: assoc
{ list? lisp-bool } 1L: list?
{ pair? lisp-bool } 1L: pair?
{ tuple? lisp-bool } 1L: tuple?
{ string? lisp-bool } 1L: string?
{ integer? lisp-bool } 1L: integer?
{ integer? lisp-bool } 1L: number?
{ count } 1L: width
{ list-length } 1L: length
{ [] } 2L: tuple-ref
{ first } 1L: first
{ second } 1L: second
{ third } 1L: third
{ 3 [] } 1L: fourth
{ list>tuple } 1L: list->tuple
{ explode list } 1L: tuple->list
null L=: null
{ atom? lisp-bool } 1L: symbol?
{ atom } 1L: string->symbol
{ atom>$ } 1L: symbol->string
{ dup #f eq? swap #t eq? or lisp-bool } 1L: boolean?
#t L=: else
#f L=: #f
#t L=: #t
{ null? lisp-bool } 1L: null?
{ 0= lisp-bool } 1L: zero?
{ 0> lisp-bool } 1L: positive?
{ 0< lisp-bool } 1L: negative?
{ 1 and 0= lisp-bool } 1L: even?
{ 1 and 0<> lisp-bool } 1L: odd?
{ bye } 0L: exit
{ .l null } 1L: write
{ lisp-eval } 1L: eval
{ drop } `quote 1 lisp-fixed-lazy-primitive
'nop L: list
{ list>tuple } L: tuple
{ list-last } L: begin
{ $len } 1L: string-length
{ concat-string-list } L: string-append
{ $= lisp-bool } 2L: string=?
{ $cmp 0< lisp-bool } 2L: string<?
{ $cmp 0<= lisp-bool } 2L: string<=?
{ $cmp 0> lisp-bool } 2L: string>?
{ $cmp 0>= lisp-bool } 2L: string>=?
{ (number) dup 1 = { drop } { ' 2drop if no-answer } cond
} 1L: string->number
{ (.) } 1L: number->string
{ box? lisp-bool } 1L: box?
{ box } 1L: box
{ hole } 0L: new-box
{ @ } 1L: unbox
{ tuck swap ! } 2L: set-box!
{ abort } 1L: error
{ dup find { nip execute } { +" -?" abort } cond } : find-execute
{ explode-list 1- roll find-execute } L: fift-exec
{ explode-list dup 1- swap roll find-execute } L: fift-exec-cnt
{ uncons swap find-execute } L: fift-exec-list
// end of basic primitives
forget L: forget #L: forget L=:
forget 0L: forget 1L: forget 2L:
{ { dup tuple? ' do-quote if } list-map } : map-quote
{ uncons ' cons foldr-ne map-quote
null swap cons lisp-dict @ rot run-definition
} `apply lisp-primitive // bad: should have preserved original context
// e1 e2 e3 ctx
{ 3 exch 3 pick lisp-ctx-eval lisp-true? ' swap if nip swap lisp-ctx-eval }
`if 3 lisp-fixed-lazy-primitive
// (e) ctx
{ #t -rot
{ over null? { 2drop true } {
swap uncons swap 2 pick lisp-ctx-eval dup lisp-true? // v' c t v ?
{ swap 2swap nip false } { -rot 2drop nip true } cond
} cond } until
} `and lisp-lazy-primitive
{ #f -rot
{ over null? { 2drop true } {
swap uncons swap 2 pick lisp-ctx-eval dup lisp-false? // v' c t v ?
{ swap 2swap nip false } { -rot 2drop nip true } cond
} cond } until
} `or lisp-lazy-primitive
{ lisp-false? lisp-bool } `not 1 lisp-fixed-primitive
// cond-clause ctx -- v -1 or 0
{ swap uncons -rot dup `else eq? {
drop lisp-ctx-eval-list-last true } {
over lisp-ctx-eval lisp-true? {
lisp-ctx-eval-list-last true } {
2drop false
} cond } cond
} : eval-cond-clause
// (clauses) ctx -- v
{ { over null? { no-answer true } {
swap uncons -rot over eval-cond-clause } cond
} until -rot 2drop
} `cond lisp-lazy-primitive
{ lisp-dict @ lookup-in { hole tuck lisp-dict-int-define } ifnot
} : lisp-create-global-var
// a e ctx -- old (simple) define
{ drop over atom? not abort"only a variable can be define'd"
over lisp-create-global-var swap lisp-eval swap !
} drop // `define 2 lisp-fixed-lazy-primitive
{ tuck lisp-ctx-eval rot dup atom? not abort"only a variable can be set"
rot lookup-or-fail dup @ -rot !
} `set! 2 lisp-fixed-lazy-primitive
// define lambda
{ { dup null? { drop true true }
{ uncons swap atom? { false } { drop false true } cond } cond
} until
} : var-list?
{ { dup null? over atom? or { drop true true }
{ uncons swap atom? { false } { drop false true } cond } cond
} until
} : lambda-var-list?
// (quote x) -- x -1 ; else 0
{ dup pair? { uncons swap `quote eq? { car true } { drop false } cond }
{ drop false } cond
} : is-quote?
recursive match-arg-list-acc
// l (vars) (args) -- ((var . arg) ...)+l -1 or ? 0
{ over atom? { over `_ eq? { 2drop } { pair swap cons } cond true } {
over null? { nip null? } { // (vars) (args)
over tuple? not { 2drop false } {
over is-quote? { eq? nip } { // (v) (a)
dup tuple? not { 2drop false } {
over count over count over <> { drop 2drop false } { // l [v] [a] n
3 roll 0 rot { // [v] [a] l i
dup 0< {
3 pick over [] swap // [v] [a] l vi i
3 pick over [] 2swap rot // [v] [a] i l vi ai
match-arg-list-acc { // [v] [a] i l'
swap 1+ } { nip -1 } cond
} ifnot
} swap times
2swap 2drop 0>=
} cond } cond } cond } cond } cond } cond
} swap !
{ null -rot match-arg-list-acc } : match-arg-list
// ((var . arg)...) ctx -- ctx'
{ { over null? not }
{ swap uncons swap unpair box pair rot cons } while
nip
} : extend-ctx-by-list
// ((vars) body) ctx
{ swap uncons -rot
dup lambda-var-list? not abort"invalid formal parameter list"
{ // l-expr ctx' [_ body ctx (vars)]
-rot 2 pick 3 [] swap rot // [_ body ...] (vars) ctx' l-expr
uncons nip swap lisp-ctx-eval-list // [_ body ...] (vars) (arg-vals)
match-arg-list not abort"invalid arguments to lambda" // [_ body ...] ((var arg)...)
over third extend-ctx-by-list // [_ body ctx (vars)] ctx''
swap second swap lisp-ctx-eval-list-last
} 3 -roll 4 tuple
} : make-lambda
{ make-lambda } `lambda lisp-lazy-primitive
// (a e) ctx -- more sophisticated (define a e)
{ drop uncons swap dup atom? { // (e) a
tuck lisp-create-global-var
swap lisp-dict @ lisp-ctx-eval-list-last swap !
} { // (e) (a v..)
uncons over atom? not abort"only variables can be define'd" // (e) a (v..)
rot cons over lisp-create-global-var // a ((v..) (e)) h
swap lisp-dict @ make-lambda swap !
} cond
} `define lisp-lazy-primitive
// ((x e) ..) ctx -- ((x.v) ..)
recursive eval-assign-list
{ over null? { drop } {
swap uncons swap uncons // ctx t x (e)
over atom? not abort"invalid variable name in assignment list"
3 pick lisp-ctx-eval-list-last // ctx t x v
pair swap rot eval-assign-list cons
} cond
} swap !
// (((x v) ..) body) ctx -- let construct
{ swap uncons swap 2 pick eval-assign-list // ctx body ((x v)...)
rot extend-ctx-by-list lisp-ctx-eval-list-last
} `let lisp-lazy-primitive
// ((x e) ..) ctx -- ctx'
{ swap {
dup null? { drop true } {
uncons swap uncons // ctx t x (e)
over atom? not abort"invalid variable name in assignment list"
3 pick lisp-ctx-eval-list-last // ctx t x v
box pair rot cons swap false
} cond } until
} : compute-let*-ctx
// (((x v) ..) body) ctx -- let* construct
{ swap uncons swap rot compute-let*-ctx lisp-ctx-eval-list-last
} `let* lisp-lazy-primitive
// ((x e) ..) ctx -- ((h e) ..) ctx' , with x bound to h in ctx'
recursive prepare-letrec-ctx {
over null? {
swap uncons swap uncons swap // ctx t (e) x
hole tuck pair swap rot cons // ctx t (x.h) (h e)
3 -roll rot cons prepare-letrec-ctx // (h e) t ctx'
-rot cons swap
} ifnot
} swap !
// (((x v) ..) body) ctx -- letrec construct
{ swap uncons swap rot prepare-letrec-ctx swap { // body ctx' ((h e)..)
dup null? { drop true } {
uncons -rot uncons 2 pick lisp-ctx-eval-list-last // body t ctx' h v
swap ! swap false
} cond } until
lisp-ctx-eval-list-last
} `letrec lisp-lazy-primitive
// (e (p e)...) ctx -- match construct
{ swap uncons swap 2 pick lisp-ctx-eval swap { // ctx v ((p e)..)
dup null? { drop 2drop no-answer true } {
uncons swap uncons swap 3 pick // ctx v t e p v
match-arg-list { // ctx v t e ((x' . v')...)
2swap 2drop rot extend-ctx-by-list lisp-ctx-eval-list-last true } {
2drop false
} cond } cond } until
} `match lisp-lazy-primitive
//
lisp-dict @ constant original-lisp-dict
{ original-lisp-dict lisp-dict ! } : reset-lisp
{ ' drop { lisp-eval .l cr } List-generic( } :_ LISP-EVAL-PRINT(
// LISP-EVAL-PRINT((+ 3 4) (* 5 6)) computes and prints 12 and 30
{ hole dup 1 { @ nip } does swap
1 { swap lisp-eval swap ! } does
List-generic(
} :_ LISP-EVAL(
// LISP-EVAL((+ 3 4) (* 5 6)) computes 12 and 30, returns only 30
// words for invoking Lisp definitions from Fift
// (args) def -- val
{ null rot map-quote cons lisp-dict @ rot run-definition
} : invoke-lisp-definition
{ atom lisp-dict-lookup 1 { @ invoke-lisp-definition }
} : (invoke-lisp)
{ bl word (invoke-lisp) } :: invoke-lisp
// ( 2 3 ) invoke-lisp compare .l
{ atom lisp-dict-lookup 2 { @ mklist-1 invoke-lisp-definition }
} : (invoke-lisp-fixed)
{ bl word (invoke-lisp-fixed) } :: invoke-lisp-fixed
// 9 8 2 invoke-lisp-fixed compare .l
{ bl word (invoke-lisp) does } : make-lisp-invoker
{ bl word (invoke-lisp-fixed) does } : make-lisp-fixed-invoker
// 2 make-lisp-fixed-invoker compare : compare
// 3 9 compare
// import Lisp definitions as Fift words
{ bl word dup (invoke-lisp) does swap 0 (create) } : import-lisp
{ bl word tuck (invoke-lisp-fixed) does swap 0 (create) } : import-lisp-fixed
// 1 import-lisp-fixed fact
// 7 fact .