rubymotionlisp 0.1.3

Sign up to get free protection for your applications and to get access to all the features.
@@ -0,0 +1,527 @@
1
+ module Lisp
2
+
3
+ class ListSupport
4
+
5
+ def self.register
6
+ %w(car cdr caar cadr cdar cddr
7
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
8
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
9
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr).each do |name|
10
+ Primitive.register(name) {|args, env| ad_impl(args, env, name) }
11
+ end
12
+ Primitive.register("list") {|args, env| Lisp::ListSupport::list_impl(args, env) }
13
+ Primitive.register("vector") {|args, env| Lisp::ListSupport::vector_impl(args, env) }
14
+ Primitive.register("cons*") {|args, env| Lisp::ListSupport::cons_star_impl(args, env) }
15
+ Primitive.register("cons") {|args, env| Lisp::ListSupport::cons_impl(args, env) }
16
+ Primitive.register("make-list") {|args, env| Lisp::ListSupport::make_list_impl(args, env) }
17
+ Primitive.register("iota") {|args, env| Lisp::ListSupport::iota_impl(args, env) }
18
+
19
+ Primitive.register("length") {|args, env| Lisp::ListSupport::length_impl(args, env) }
20
+ Primitive.register("first") {|args, env| Lisp::ListSupport::first_impl(args, env) }
21
+ Primitive.register("head") {|args, env| Lisp::ListSupport::first_impl(args, env) }
22
+ Primitive.register("rest") {|args, env| Lisp::ListSupport::rest_impl(args, env) }
23
+ Primitive.register("tail") {|args, env| Lisp::ListSupport::rest_impl(args, env) }
24
+ Primitive.register("second") {|args, env| Lisp::ListSupport::second_impl(args, env) }
25
+ Primitive.register("third") {|args, env| Lisp::ListSupport::third_impl(args, env) }
26
+ Primitive.register("fourth") {|args, env| Lisp::ListSupport::fourth_impl(args, env) }
27
+ Primitive.register("fifth") {|args, env| Lisp::ListSupport::fifth_impl(args, env) }
28
+ Primitive.register("sixth") {|args, env| Lisp::ListSupport::sixth_impl(args, env) }
29
+ Primitive.register("seventh") {|args, env| Lisp::ListSupport::seventh_impl(args, env) }
30
+ Primitive.register("eighth") {|args, env| Lisp::ListSupport::eighth_impl(args, env) }
31
+ Primitive.register("ninth") {|args, env| Lisp::ListSupport::ninth_impl(args, env) }
32
+ Primitive.register("tenth") {|args, env| Lisp::ListSupport::tenth_impl(args, env) }
33
+ Primitive.register("nth") {|args, env| Lisp::ListSupport::nth_impl(args, env) }
34
+
35
+ Primitive.register("sublist") {|args, env| Lisp::ListSupport::sublist_impl(args, env) }
36
+ Primitive.register("list-head") {|args, env| Lisp::ListSupport::list_head_impl(args, env) }
37
+ Primitive.register("take") {|args, env| Lisp::ListSupport::take_impl(args, env) }
38
+ Primitive.register("list-tail") {|args, env| Lisp::ListSupport::list_tail_impl(args, env) }
39
+ Primitive.register("drop") {|args, env| Lisp::ListSupport::drop_impl(args, env) }
40
+ Primitive.register("last-pair") {|args, env| Lisp::ListSupport::last_pair_impl(args, env) }
41
+
42
+ Primitive.register("memq") {|args, env| Lisp::ListSupport::memq_impl(args, env) }
43
+ Primitive.register("memv") {|args, env| Lisp::ListSupport::memv_impl(args, env) }
44
+ Primitive.register("member") {|args, env| Lisp::ListSupport::member_impl(args, env) }
45
+
46
+ Primitive.register("filter") {|args, env| Lisp::ListSupport::filter_impl(args, env) }
47
+ Primitive.register("remove") {|args, env| Lisp::ListSupport::remove_impl(args, env) }
48
+ Primitive.register("partition") {|args, env| Lisp::ListSupport::partition_impl(args, env) }
49
+ Primitive.register("map") {|args, env| Lisp::ListSupport::map_impl(args, env) }
50
+ Primitive.register("reduce-left") {|args, env| Lisp::ListSupport::reduce_left_impl(args, env) }
51
+ Primitive.register("any") {|args, env| Lisp::ListSupport::any_impl(args, env) }
52
+ Primitive.register("every") {|args, env| Lisp::ListSupport::every_impl(args, env) }
53
+ Primitive.register("reverse") {|args, env| Lisp::ListSupport::reverse_impl(args, env) }
54
+ Primitive.register("append") {|args, env| Lisp::ListSupport::append_impl(args, env) }
55
+ Primitive.register("append!") {|args, env| Lisp::ListSupport::appendbang_impl(args, env) }
56
+ Primitive.register("flatten") {|args, env| Lisp::ListSupport::flatten_impl(args, env) }
57
+ # Primitive.register("flatten*") {|args, env| Lisp::ListSupport::recursive_flatten_impl(args, env) }
58
+ end
59
+
60
+
61
+ def self.cons_impl(args, env)
62
+ raise "cons requires two arguments." unless args.length == 2
63
+ left = args.car.evaluate(env)
64
+ right = args.cadr.evaluate(env)
65
+ Lisp::ConsCell.cons(left, right)
66
+ end
67
+
68
+
69
+ def self.cons_star_impl(args, env)
70
+ vals = []
71
+ args.each {|item| vals << item.evaluate(env) }
72
+ Lisp::ConsCell::array_to_list(vals[0..-2], vals[-1])
73
+ end
74
+
75
+
76
+ def self.list_impl(args, env)
77
+ vals = []
78
+ args.each {|item| vals << item.evaluate(env) }
79
+ if vals.size == 1 && vals[0].vector?
80
+ Lisp::ConsCell::array_to_list(vals[0].value)
81
+ else
82
+ Lisp::ConsCell::array_to_list(vals)
83
+ end
84
+ end
85
+
86
+
87
+ def self.make_list_impl(args, env)
88
+ raise "consmake-list requires one or two arguments." unless args.length == 1 || args.length == 2
89
+ arg1 = args.car.evaluate(env)
90
+ raise "make-list requires an integer for it's first argument, received: #{args.car}" unless arg1.integer?
91
+ count = arg1.value
92
+ val = if args.length == 1
93
+ nil
94
+ else
95
+ args.cadr.evaluate(env)
96
+ end
97
+
98
+ vals = Array.new(count, val)
99
+ Lisp::ConsCell::array_to_list(vals)
100
+ end
101
+
102
+
103
+ def self.iota_impl(args, env)
104
+ raise "iota requires at least one argument." unless args.length > 0
105
+ arg1 = args.car.evaluate(env)
106
+ raise "iota requires an positive integer for it's first argument, received: #{args.car}" unless arg1.integer? && arg1.positive?
107
+ count = arg1.value
108
+
109
+ start = if args.length < 2
110
+ 0
111
+ else
112
+ arg2 = args.cadr.evaluate(env)
113
+ raise "iota requires an number for it's second argument, received: #{args.cadr}" unless arg2.number?
114
+ arg2.value
115
+ end
116
+
117
+ step = if args.length < 3
118
+ 1
119
+ else
120
+ arg3 = args.caddr.evaluate(env)
121
+ raise "iota requires an number for it's third argument, received: #{args.caddr}" unless arg3.number?
122
+ arg3.value
123
+ end
124
+
125
+ vals = []
126
+ count.times do |c|
127
+ vals << start
128
+ start += step
129
+ end
130
+
131
+ Lisp::ConsCell::array_to_list(vals.map {|v| Number.with_value(v) })
132
+ end
133
+
134
+
135
+ def self.length_impl(args, env)
136
+ Lisp::Number.with_value(args.car.evaluate(env).length)
137
+ end
138
+
139
+
140
+ # in support of all the CxR functions
141
+ def self.ad_impl(args, env, f)
142
+ l = args.car.evaluate(env)
143
+ raise "list required." unless l.list?
144
+ l.send(f)
145
+ end
146
+
147
+
148
+ def self.first_impl(args, env)
149
+ l = args.car.evaluate(env)
150
+ raise "rest requires a list or vector." unless l.list? || l.vector?
151
+ raise "list index out of bounds" unless l.length >= 1
152
+ l.nth(1)
153
+ end
154
+
155
+
156
+ def self.rest_impl(args, env)
157
+ l = args.car.evaluate(env)
158
+ raise "rest requires a list or vector." unless l.list? || l.vector?
159
+ if l.list?
160
+ l.cdr
161
+ else
162
+ Lisp::Vector.new(l.value[1..-1])
163
+ end
164
+ end
165
+
166
+
167
+ def self.second_impl(args, env)
168
+ l = args.car.evaluate(env)
169
+ raise "rest requires a list or vector." unless l.list? || l.vector?
170
+ raise "list index out of bounds" unless l.length >= 2
171
+ l.nth(2)
172
+ end
173
+
174
+ def self.third_impl(args, env)
175
+ l = args.car.evaluate(env)
176
+ raise "rest requires a list or vector." unless l.list? || l.vector?
177
+ raise "list index out of bounds" unless l.length >= 3
178
+ l.nth(3)
179
+ end
180
+
181
+
182
+ def self.fourth_impl(args, env)
183
+ l = args.car.evaluate(env)
184
+ raise "rest requires a list or vector." unless l.list? || l.vector?
185
+ raise "list index out of bounds" unless l.length >= 4
186
+ l.nth(4)
187
+ end
188
+
189
+
190
+ def self.fifth_impl(args, env)
191
+ l = args.car.evaluate(env)
192
+ raise "rest requires a list or vector." unless l.list? || l.vector?
193
+ raise "list index out of bounds" unless l.length >= 5
194
+ l.nth(5)
195
+ end
196
+
197
+
198
+ def self.sixth_impl(args, env)
199
+ l = args.car.evaluate(env)
200
+ raise "rest requires a list or vector." unless l.list? || l.vector?
201
+ raise "list index out of bounds" unless l.length >= 6
202
+ l.nth(6)
203
+ end
204
+
205
+
206
+ def self.seventh_impl(args, env)
207
+ l = args.car.evaluate(env)
208
+ raise "rest requires a list or vector." unless l.list? || l.vector?
209
+ raise "list index out of bounds" unless l.length >= 7
210
+ l.nth(7)
211
+ end
212
+
213
+
214
+ def self.eighth_impl(args, env)
215
+ l = args.car.evaluate(env)
216
+ raise "rest requires a list or vector." unless l.list? || l.vector?
217
+ raise "list index out of bounds" unless l.length >= 8
218
+ l.nth(8)
219
+ end
220
+
221
+
222
+ def self.ninth_impl(args, env)
223
+ l = args.car.evaluate(env)
224
+ raise "rest requires a list or vector." unless l.list? || l.vector?
225
+ raise "list index out of bounds" unless l.length >= 9
226
+ l.nth(9)
227
+ end
228
+
229
+
230
+ def self.tenth_impl(args, env)
231
+ l = args.car.evaluate(env)
232
+ raise "rest requires a list or vector." unless l.list? || l.vector?
233
+ raise "list index out of bounds" unless l.length >= 10
234
+ l.nth(10)
235
+ end
236
+
237
+
238
+ def self.nth_impl(args, env)
239
+ raise "nth requires 2 arguments" unless args.length == 2
240
+ n = args.car.evaluate(env)
241
+ raise "The first argument of nth has to be an number." unless n.number?
242
+ raise "The first argument of nth has to be positive." unless n.value > 0
243
+ l = args.cadr.evaluate(env)
244
+ raise "rest requires a list or vector." unless l.list? || l.vector?
245
+ l.nth(n.value)
246
+ end
247
+
248
+
249
+ def self.make_same_kind_as(sequence, value)
250
+ if sequence.vector?
251
+ Lisp::Vector.new(value)
252
+ else
253
+ Lisp::ConsCell.array_to_list(value)
254
+ end
255
+ end
256
+
257
+
258
+ def self.sublist_impl(args, env)
259
+ raise "sublist requires 3 arguments" unless args.length == 3
260
+ l = args.car.evaluate(env)
261
+ raise "sublist requires it's first argument to be a list or vector, but received #{args.car}" unless l.list? || l.vector?
262
+ st = args.cadr.evaluate(env)
263
+ raise "sublist requires it's second argument to be a positive integer, but received #{args.cadr}" unless st.number? && st.positive?
264
+ raise "sublist requires it's second argument to be <= the list length" unless st.value <= l.length
265
+ en = args.caddr.evaluate(env)
266
+ raise "sublist requires it's third argument to be a positive integer, but received #{args.caddr}" unless en.number? && en.positive?
267
+ raise "sublist requires it's third argument to be <= the list length" unless en.value <= l.length
268
+ raise "sublist requires it's second argument to be <= the third argument" unless st.value <= en.value
269
+ make_same_kind_as(l, l.to_a[(st.value - 1)...en.value])
270
+ end
271
+
272
+
273
+ def self.list_head_impl(args, env)
274
+ raise "list_head requires 2 arguments" unless args.length == 2
275
+ l = args.car.evaluate(env)
276
+ raise "list_head requires it's first argument to be a list, but received #{args.car}" unless l.list?
277
+ k = args.cadr.evaluate(env)
278
+ raise "list_head requires it's second argument to be a positive integer, but received #{args.cadr}" unless k.number? && k.positive?
279
+ raise "list_head requires it's second argument to be <= the list length" unless k.value <= l.length
280
+ Lisp::ConsCell.array_to_list(l.to_a[0...k.value])
281
+ end
282
+
283
+
284
+ def self.take_impl(args, env)
285
+ raise "take requires 2 arguments" unless args.length == 2
286
+ k = args.car.evaluate(env)
287
+ raise "take requires it's first argument to be an integer >= 0, but received #{args.car}" unless k.number? && !k.negative?
288
+ l = args.cadr.evaluate(env)
289
+ raise "take requires it's second argument to be a list or vector, but received #{args.cadr}" unless l.list? || l.vector?
290
+ raise "take requires it's first argument to be <= the list length" unless k.value <= l.length
291
+ puts l
292
+ make_same_kind_as(l, l.to_a[0...k.value])
293
+ end
294
+
295
+
296
+ def self.list_tail_impl(args, env)
297
+ raise "list_head requires 2 arguments" unless args.length == 2
298
+ l = args.car.evaluate(env)
299
+ raise "list_head requires it's first argument to be a list, but received #{args.car}" unless l.list?
300
+ k = args.cadr.evaluate(env)
301
+ raise "list_head requires it's second argument to be a positive integer, but received #{args.cadr}" unless k.number? && k.positive?
302
+ raise "list_head requires it's second argument to be <= the list length" unless k.value <= l.length
303
+ l.nth_tail(k.value + 1)
304
+ end
305
+
306
+
307
+ def self.drop_impl(args, env)
308
+ raise "drop requires 2 arguments" unless args.length == 2
309
+ k = args.car.evaluate(env)
310
+ raise "drop requires it's first argument to be an integer >= 0, but received #{args.car}" unless k.number? && !k.negative?
311
+ l = args.cadr.evaluate(env)
312
+ raise "drop requires it's second argument to be a list or vector, but received #{args.cadr}" unless l.list? || l.vector?
313
+ raise "drop requires it's first argument to be <= the list length" unless k.value <= l.length
314
+ l.nth_tail(k.value + 1)
315
+ end
316
+
317
+
318
+ def self.last_pair_impl(args, env)
319
+ raise "last_pair requires 1 arguments" unless args.length == 1
320
+ l = args.car.evaluate(env)
321
+ raise "last_pair requires it's argument to be a list, but received #{args.car}" unless l.list?
322
+ l.last
323
+ end
324
+
325
+
326
+ def self.memq_impl(args, env)
327
+ raise "memq requires 2 arguments but received #{args.length}." unless args.length == 2
328
+ item = args.car.evaluate(env)
329
+ collection = args.cadr.evaluate(env)
330
+ raise "memq requires a list as it's second argument." unless collection.list?
331
+ collection.length.times do |i|
332
+ if Lisp::Equivalence.eq_check(item, collection.nth(i + 1)).value
333
+ return collection.nth_tail(i + 1)
334
+ end
335
+ end
336
+ Lisp::FALSE
337
+ end
338
+
339
+
340
+ def self.memv_impl(args, env)
341
+ raise "memv requires 2 arguments but received #{args.length}." unless args.length == 2
342
+ item = args.car.evaluate(env)
343
+ collection = args.cadr.evaluate(env)
344
+ raise "memv requires a list as it's second argument." unless collection.list?
345
+ collection.length.times do |i|
346
+ if Lisp::Equivalence.eqv_check(item, collection.nth(i + 1)).value
347
+ return collection.nth_tail(i + 1)
348
+ end
349
+ end
350
+ Lisp::FALSE
351
+ end
352
+
353
+
354
+ def self.member_impl(args, env)
355
+ raise "member requires 2 arguments but received #{args.length}." unless args.length == 2
356
+ item = args.car.evaluate(env)
357
+ collection = args.cadr.evaluate(env)
358
+ raise "member requires a list as it's second argument." unless collection.list?
359
+ collection.length.times do |i|
360
+ if Lisp::Equivalence.equal_check(item, collection.nth(i + 1)).value
361
+ return collection.nth_tail(i + 1)
362
+ end
363
+ end
364
+ Lisp::FALSE
365
+ end
366
+
367
+
368
+ def self.filter_impl(args, env)
369
+ raise "filter requires 2 arguments but received #{args.length}." unless args.length == 2
370
+ f = args.car.evaluate(env)
371
+ raise "filter requires a function as it's first argument but received #{args.car}." unless f.function? || f.primitive?
372
+ collection = args.cadr.evaluate(env)
373
+ raise "filter requires a list or vector as it's second argument but received #{args.cadr}." unless collection.list? || collection.vector?
374
+ results = collection.to_a.select {|item| f.apply_to_without_evaluating(Lisp::ConsCell.cons(item, nil), env).value }
375
+ make_same_kind_as(collection, results)
376
+ end
377
+
378
+
379
+ def self.remove_impl(args, env)
380
+ raise "remove requires 2 arguments but received #{args.length}." unless args.length == 2
381
+ f = args.car.evaluate(env)
382
+ raise "remove requires a function as it's first argument but received #{args.car}." unless f.function? || f.primitive?
383
+ collection = args.cadr.evaluate(env)
384
+ raise "remove requires a list or vector as it's second argument but received #{args.cadr}." unless collection.list? || collection.vector?
385
+ results = collection.to_a.reject {|item| f.apply_to_without_evaluating(Lisp::ConsCell.cons(item, nil), env).value }
386
+ make_same_kind_as(collection, results)
387
+ end
388
+
389
+
390
+ def self.partition_impl(args, env)
391
+ raise "partition requires 2 arguments but received #{args.length}." unless args.length == 2
392
+ f = args.car.evaluate(env)
393
+ raise "partition requires a function as it's first argument." unless f.function? || f.primitive?
394
+ collection = args.cadr.evaluate(env)
395
+ raise "partition requires a list as it's second argument." unless collection.list? | collection.vector?
396
+ results = collection.to_a.partition {|item| f.apply_to_without_evaluating(Lisp::ConsCell.cons(item, nil), env).value }
397
+ matches = make_same_kind_as(collection, results[0])
398
+ non_matches = make_same_kind_as(collection, results[1])
399
+ Lisp::ConsCell.array_to_list([matches, non_matches])
400
+ end
401
+
402
+
403
+ def self.map_impl(args, env)
404
+ raise "map requires at least 2 arguments but received #{args.length}." if args.length < 2
405
+ f = args.car.evaluate(env)
406
+ raise "map requires a function as it's first argument but received #{args.car}." unless f.function? || f.primitive?
407
+ collections = args.cdr.to_a.collect {|a| a.evaluate(env)}
408
+ raise "all requires all subsequent arguments to be lists or vectors" unless collections.all? {|l| l.list? || l.vector?}
409
+ all_vectors = collections.all? {|i| i.vector?}
410
+ lists = collections.collect {|l| l.to_a }
411
+
412
+ map_args = []
413
+ while (lists.all? {|l| !l.empty? })
414
+ map_args << Lisp::ConsCell.array_to_list(lists.map {|l| l.shift })
415
+ end
416
+ results = map_args.collect {|item| f.apply_to_without_evaluating(item, env) }
417
+ if all_vectors
418
+ Lisp::Vector.new(results)
419
+ else
420
+ Lisp::ConsCell.array_to_list(results)
421
+ end
422
+
423
+ end
424
+
425
+
426
+ def self.quote_if_required(thing)
427
+ return thing unless thing.list? || thing.symbol?
428
+ thing.quoted
429
+ end
430
+
431
+
432
+ def self.reduce_left_impl(args, env)
433
+ raise "reduce requires 3 arguments but received #{args.length}." unless args.length == 3
434
+ f = args.car.evaluate(env)
435
+ raise "map requires a function as it's first argument but received #{args.car}." unless f.function? || f.primitive?
436
+ initial = args.cadr.evaluate(env)
437
+ collection = args.caddr.evaluate(env)
438
+ raise "reduce requires a list or vector as it's third argument but received #{args.caddr}." unless collection.list? || collection.vector?
439
+ return initial if collection.empty?
440
+ return collection.nth(1) if collection.length == 1
441
+ result = collection.to_a.inject do |acc, item|
442
+ f.apply_to(Lisp::ConsCell.array_to_list([quote_if_required(acc), quote_if_required(item)]), env)
443
+ end
444
+ result
445
+ end
446
+
447
+
448
+ def self.any_impl(args, env)
449
+ raise "any requires at least two arguments" unless args.length >= 2
450
+ p = args.car.evaluate(env)
451
+ raise "any requires a function as it's first argument" unless p.function? || p.primitive?
452
+ lists = args.cdr.to_a.collect {|a| a.evaluate(env)}
453
+ raise "any requires all subsequent arguments to be lists or vectors" unless lists.all? {|l| l.list? || l.vector?}
454
+
455
+ while true
456
+ cars = lists.collect {|l| l.nth(1)}
457
+ return_val = p.apply_to(Lisp::ConsCell.array_to_list(cars), env)
458
+ return Lisp::TRUE if return_val.value
459
+ lists = lists.collect {|l| l.nth_tail(2)}
460
+ return Lisp::FALSE if lists.any? {|l| l.empty?}
461
+ end
462
+ end
463
+
464
+
465
+ def self.every_impl(args, env)
466
+ raise "all requires at least two arguments" unless args.length >= 2
467
+ p = args.car.evaluate(env)
468
+ raise "all requires a function as it's first argument" unless p.function? || p.primitive?
469
+ lists = args.cdr.to_a.collect {|a| a.evaluate(env)}
470
+ raise "all requires all subsequent arguments to be lists or vectors" unless lists.all? {|l| l.list? || l.vector?}
471
+
472
+ while true
473
+ cars = lists.collect {|l| l.nth(1)}
474
+ return_val = p.apply_to(Lisp::ConsCell.array_to_list(cars), env)
475
+ return Lisp::FALSE unless return_val.value
476
+ lists = lists.collect {|l| l.nth_tail(2)}
477
+ return Lisp::TRUE if lists.any? {|l| l.empty?}
478
+ end
479
+ end
480
+
481
+
482
+ def self.reverse_impl(args, env)
483
+ raise "reverse requires a single argument." unless args.length == 1
484
+ l = args.car.evaluate(env)
485
+ raise "reverse requires a list or vector" unless l.list? || l.vector?
486
+ make_same_kind_as(l, l.to_a.reverse)
487
+ end
488
+
489
+
490
+ def self.append_impl(args, env)
491
+ raise "append requires at least 1 argument." unless args.length >= 1
492
+ l = args.map {|i| i.evaluate(env)}
493
+ raise "append requires lists or vectors" unless l.all? {|i| i.list? || i.vector?}
494
+ all_vectors = l.all? {|i| i.vector?}
495
+ new_items = []
496
+ l.each do |sublist|
497
+ sublist.each {|item| new_items << item.copy}
498
+ end
499
+
500
+ if all_vectors
501
+ Lisp::Vector.new(new_items)
502
+ else
503
+ Lisp::ConsCell.array_to_list(new_items)
504
+ end
505
+ end
506
+
507
+
508
+ def self.appendbang_impl(args, env)
509
+ raise "append! requires at least 1 argument." unless args.length >= 1
510
+ arg_array = args.to_a.map {|i| i.evaluate(env)}
511
+ raise "append! requires lists" unless arg_array.all? {|i| i.list?}
512
+ (0...(arg_array.length-1)). each do |i|
513
+ arg_array[i].last.set_cdr!(arg_array[i+1])
514
+ end
515
+ arg_array[0]
516
+ end
517
+
518
+
519
+ def self.flatten_impl(args, env)
520
+ raise "flatten requires 1 argument." unless args.length != 1
521
+ l = args.car.evaluate(env)
522
+ raise "flatten requires a list argument" unless l.list?
523
+ l.flatten
524
+ end
525
+
526
+ end
527
+ end
@@ -0,0 +1,38 @@
1
+ module Lisp
2
+
3
+ class Logical
4
+
5
+ def self.register
6
+ Primitive.register("or",
7
+ "(or expression ...\n\nThe expressions are evaluated from left to right, and the value of the first expression that evaluates to a true value is returned. Any remaining expressions are not evaluated. If all expressions evaluate to false values, the value of the last expression is returned. If there are no expressions then #f is returned.",
8
+ true) do |args, env|
9
+ Lisp::Logical::or_impl(args, env)
10
+ end
11
+ Primitive.register("and",
12
+ "(and expression ...)\n\nThe expressions are evaluated from left to right, and the value of the first expression that evaluates to a false value is returned. Any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then #t is returned.",
13
+ true) do |args, env|
14
+ Lisp::Logical::and_impl(args, env)
15
+ end
16
+ Primitive.register("not") {|args, env| Lisp::Logical::not_impl(args, env) }
17
+ end
18
+
19
+
20
+ def self.or_impl(args, env)
21
+ raise "or needs at least 2 arguments" unless args.length > 1
22
+ value = !!args.inject(false) {|acc, item| acc || item.evaluate(env).value}
23
+ return Lisp::Boolean.with_value(value)
24
+ end
25
+
26
+ def self.and_impl(args, env)
27
+ raise "and needs at least 2 arguments" unless args.length > 1
28
+ value = !!args.inject(true) {|acc, item| acc && item.evaluate(env).value}
29
+ return Lisp::Boolean.with_value(value)
30
+ end
31
+
32
+ def self.not_impl(args, env)
33
+ raise "not needs a single argument" unless args.length == 1
34
+ return Lisp::Boolean.with_value(!(args.car.evaluate(env).value))
35
+ end
36
+
37
+ end
38
+ end
@@ -0,0 +1,95 @@
1
+ module Lisp
2
+
3
+ class Macro < Atom
4
+
5
+ attr_reader :doc
6
+
7
+ def compute_required_argument_count(args)
8
+ a = args
9
+ @required_argument_count = 0
10
+ @var_args = false
11
+ while a
12
+ if a.symbol?
13
+ @var_args = true
14
+ return
15
+ else
16
+ @required_argument_count += 1
17
+ end
18
+ a = a.cdr
19
+ end
20
+ end
21
+
22
+ def initialize(name, arguments, doc, body, env)
23
+ sig = ([name] << arguments.to_a).flatten
24
+ @doc = "(#{(sig.collect {|e| e.to_s}).join(" ")})"
25
+ @name = name
26
+ @arguments = arguments
27
+ @doc = [@doc, doc].join("\n\n") unless doc.nil? || doc.to_s.empty?
28
+ @body = body
29
+ @env = env
30
+ @local_env = nil
31
+ compute_required_argument_count(@arguments)
32
+ end
33
+
34
+ def expand(parameters, env, should_eval)
35
+ if @var_args
36
+ raise "#{@name} expected at least #{@required_argument_count} parameters, received #{parameters.length}." if parameters.length < @required_argument_count
37
+ else
38
+ raise "#{@name} expected #{@required_argument_count} parameters, received #{parameters.length}." unless parameters.length == @required_argument_count
39
+ end
40
+
41
+ local_env = EnvironmentFrame.extending(@env, env.frame)
42
+ self_sym = Symbol.named("self")
43
+ if env.frame
44
+ local_env.bind_locally(self_sym, env.frame)
45
+ elsif env.local_binding_for(self_sym)
46
+ local_env.bind_locally(self_sym, env.value_of(self_sym))
47
+ end
48
+ arg = @arguments
49
+ param = parameters
50
+ accumulating_arg = nil
51
+ accumulated_params = []
52
+ while !param.nil?
53
+ param_value = should_eval ? param.car.evaluate(env) : param.car
54
+ if accumulating_arg
55
+ accumulated_params << param_value
56
+ else
57
+ local_env.bind_locally(arg.car, param_value) unless arg.car.nil?
58
+ end
59
+ param = param.cdr
60
+ arg = arg.cdr unless accumulating_arg
61
+ accumulating_arg = arg if arg.symbol?
62
+ end
63
+ local_env.bind_locally(accumulating_arg, Lisp::ConsCell.array_to_list(accumulated_params)) if accumulating_arg
64
+
65
+ @body.evaluate(local_env)
66
+ end
67
+
68
+ def internal_apply_to(parameters, env, should_eval)
69
+ expanded_macro = expand(parameters, env, should_eval)
70
+ expanded_macro.evaluate(env)
71
+ end
72
+
73
+ def apply_to(parameters, env)
74
+ internal_apply_to(parameters, env, false)
75
+ end
76
+
77
+ def apply_to_without_evaluating(parameters, env)
78
+ internal_apply_to(parameters, env, false)
79
+ end
80
+
81
+ def to_s
82
+ "<macro: #{@name}>"
83
+ end
84
+
85
+ def macro?
86
+ true
87
+ end
88
+
89
+ def type
90
+ :macro
91
+ end
92
+
93
+ end
94
+
95
+ end