1 |
|
(define-module (lang elisp primitives lists) |
2 |
|
#:use-module (lang elisp internals fset) |
3 |
|
#:use-module (lang elisp internals null) |
4 |
|
#:use-module (lang elisp internals signal)) |
5 |
|
|
6 |
|
(fset 'cons |
7 |
|
(lambda (x y) |
8 |
|
(cons x (or y '())))) |
9 |
|
|
10 |
|
(fset 'null null) |
11 |
|
|
12 |
|
(fset 'not null) |
13 |
|
|
14 |
|
(fset 'car |
15 |
|
(lambda (l) |
16 |
|
(if (null l) |
17 |
|
#f |
18 |
|
(car l)))) |
19 |
|
|
20 |
|
(fset 'cdr |
21 |
|
(lambda (l) |
22 |
|
(if (null l) |
23 |
|
#f |
24 |
|
(cdr l)))) |
25 |
|
|
26 |
|
(fset 'eq |
27 |
|
(lambda (x y) |
28 |
|
(or (eq? x y) |
29 |
|
(and (null x) (null y))))) |
30 |
|
|
31 |
|
(fset 'equal |
32 |
|
(lambda (x y) |
33 |
|
(or (equal? x y) |
34 |
|
(and (null x) (null y))))) |
35 |
|
|
36 |
|
(fset 'setcar set-car!) |
37 |
|
|
38 |
|
(fset 'setcdr |
39 |
|
(lambda (cell newcdr) |
40 |
|
(set-cdr! cell |
41 |
|
(if (null newcdr) |
42 |
|
'() |
43 |
|
newcdr)))) |
44 |
|
|
45 |
|
(for-each (lambda (sym proc) |
46 |
|
(fset sym |
47 |
|
(lambda (elt list) |
48 |
|
(if (null list) |
49 |
|
#f |
50 |
|
(if (null elt) |
51 |
|
(or (proc #f list) |
52 |
|
(proc '() list)) |
53 |
|
(proc elt list)))))) |
54 |
|
'( memq member assq assoc) |
55 |
|
`(,memq ,member ,assq ,assoc)) |
56 |
|
|
57 |
|
(fset 'length |
58 |
|
(lambda (x) |
59 |
|
(cond ((null x) 0) |
60 |
|
((pair? x) (length x)) |
61 |
|
((vector? x) (vector-length x)) |
62 |
|
((string? x) (string-length x)) |
63 |
|
(else (wta 'sequencep x 1))))) |
64 |
|
|
65 |
|
(fset 'copy-sequence |
66 |
|
(lambda (x) |
67 |
|
(cond ((list? x) (list-copy x)) |
68 |
|
((vector? x) (error "Vector copy not yet implemented")) |
69 |
|
((string? x) (string-copy x)) |
70 |
|
(else (wta 'sequencep x 1))))) |
71 |
|
|
72 |
|
(fset 'elt |
73 |
|
(lambda (obj i) |
74 |
|
(cond ((pair? obj) (list-ref obj i)) |
75 |
|
((vector? obj) (vector-ref obj i)) |
76 |
|
((string? obj) (char->integer (string-ref obj i)))))) |
77 |
|
|
78 |
|
(fset 'list list) |
79 |
|
|
80 |
|
(fset 'mapcar |
81 |
|
(lambda (function sequence) |
82 |
|
(map (lambda (elt) |
83 |
|
(elisp-apply function (list elt))) |
84 |
|
(cond ((null sequence) '()) |
85 |
|
((list? sequence) sequence) |
86 |
|
((vector? sequence) (vector->list sequence)) |
87 |
|
((string? sequence) (map char->integer (string->list sequence))) |
88 |
|
(else (wta 'sequencep sequence 2)))))) |
89 |
|
|
90 |
|
(fset 'nth |
91 |
|
(lambda (n list) |
92 |
|
(if (or (null list) |
93 |
|
(>= n (length list))) |
94 |
|
#f |
95 |
|
(list-ref list n)))) |
96 |
|
|
97 |
|
(fset 'listp |
98 |
|
(lambda (object) |
99 |
|
(or (null object) |
100 |
|
(list? object)))) |
101 |
|
|
102 |
|
(fset 'consp pair?) |
103 |
|
|
104 |
|
(fset 'nconc |
105 |
|
(lambda args |
106 |
|
(apply append! (map (lambda (arg) |
107 |
|
(if arg arg '())) |
108 |
|
args)))) |