Commit | Line | Data |
---|---|---|
60801ed6 C |
1 | require env.fs |
2 | ||
3 | 0 MalEnv. constant core | |
4 | ||
136ce7c9 | 5 | : args-as-native { argv argc -- entry*argc... } |
60801ed6 C |
6 | argc 0 ?do |
7 | argv i cells + @ as-native | |
8 | loop ; | |
9 | ||
c4403c17 C |
10 | : defcore* ( sym xt ) |
11 | MalNativeFn. core env/set ; | |
12 | ||
13 | : defcore | |
14 | parse-allot-name MalSymbol. ( xt ) | |
15 | ['] defcore* :noname ; | |
16 | ||
17 | defcore + args-as-native + MalInt. ;; | |
18 | defcore - args-as-native - MalInt. ;; | |
19 | defcore * args-as-native * MalInt. ;; | |
20 | defcore / args-as-native / MalInt. ;; | |
21 | defcore < args-as-native < mal-bool ;; | |
22 | defcore > args-as-native > mal-bool ;; | |
23 | defcore <= args-as-native <= mal-bool ;; | |
24 | defcore >= args-as-native >= mal-bool ;; | |
25 | ||
26 | defcore list { argv argc } | |
60801ed6 C |
27 | argc cells allocate throw { start } |
28 | argv start argc cells cmove | |
224e09ed C |
29 | start argc MalList. ;; |
30 | ||
31 | defcore vector { argv argc } | |
32 | argc cells allocate throw { start } | |
33 | argv start argc cells cmove | |
34 | start argc MalList. | |
35 | MalVector new swap over MalVector/list ! ;; | |
c4403c17 | 36 | |
c4403c17 C |
37 | defcore empty? drop @ empty? ;; |
38 | defcore count drop @ mal-count ;; | |
39 | ||
40 | defcore = drop dup @ swap cell+ @ swap m= mal-bool ;; | |
41 | defcore not | |
42 | drop @ | |
43 | dup mal-nil = if | |
44 | drop mal-true | |
45 | else | |
46 | mal-false = if | |
47 | mal-true | |
48 | else | |
49 | mal-false | |
50 | endif | |
51 | endif ;; | |
52 | ||
785786c6 C |
53 | : pr-str-multi ( readably? argv argc ) |
54 | ?dup 0= if drop 0 0 | |
c4403c17 C |
55 | else |
56 | { argv argc } | |
57 | new-str | |
58 | argv @ pr-buf | |
59 | argc 1 ?do | |
60 | a-space | |
61 | argv i cells + @ pr-buf | |
62 | loop | |
63 | endif ; | |
60801ed6 | 64 | |
785786c6 C |
65 | defcore prn true -rot pr-str-multi type cr drop mal-nil ;; |
66 | defcore pr-str true -rot pr-str-multi MalString. nip ;; | |
67 | defcore println false -rot pr-str-multi type cr drop mal-nil ;; | |
68 | defcore str ( argv argc ) | |
69 | dup 0= if | |
70 | MalString. | |
71 | else | |
72 | { argv argc } | |
73 | false new-str | |
74 | argc 0 ?do | |
75 | argv i cells + @ pr-buf | |
76 | loop | |
77 | MalString. nip | |
78 | endif ;; | |
bf6a574e C |
79 | |
80 | defcore read-string drop @ unpack-str read-str ;; | |
81 | defcore slurp drop @ unpack-str slurp-file MalString. ;; | |
794bfca1 C |
82 | |
83 | defcore cons ( argv[item,coll] argc ) | |
84 | drop dup @ swap cell+ @ ( item coll ) | |
85 | to-list conj ;; | |
86 | ||
87 | defcore concat { lists argc } | |
794bfca1 | 88 | MalList new |
224e09ed C |
89 | lists over MalList/start ! |
90 | argc over MalList/count ! | |
91 | MalList/concat ;; | |
92 | ||
93 | defcore conj { argv argc } | |
94 | argv @ ( coll ) | |
95 | argc 1 ?do | |
96 | argv i cells + @ swap conj | |
97 | loop ;; | |
98 | ||
99 | defcore assoc { argv argc } | |
100 | argv @ ( coll ) | |
101 | argv argc cells + argv cell+ +do | |
102 | i @ \ key | |
103 | i cell+ @ \ val | |
104 | rot assoc | |
105 | 2 cells +loop ;; | |
106 | ||
107 | defcore keys ( argv argc ) | |
108 | drop @ MalMap/list @ | |
109 | dup MalList/start @ swap MalList/count @ { start count } | |
110 | here | |
111 | start count cells + start +do | |
112 | i @ , | |
113 | 2 cells +loop | |
114 | here>MalList ;; | |
115 | ||
116 | defcore vals ( argv argc ) | |
117 | drop @ MalMap/list @ | |
118 | dup MalList/start @ swap MalList/count @ { start count } | |
119 | here | |
120 | start count cells + start cell+ +do | |
121 | i @ , | |
122 | 2 cells +loop | |
123 | here>MalList ;; | |
124 | ||
125 | defcore dissoc { argv argc } | |
126 | argv @ \ coll | |
127 | argv argc cells + argv cell+ +do | |
128 | i @ swap dissoc | |
129 | cell +loop ;; | |
130 | ||
131 | defcore hash-map { argv argc } | |
132 | MalMap/Empty | |
133 | argc cells argv + argv +do | |
134 | i @ i cell+ @ rot assoc | |
135 | 2 cells +loop ;; | |
136 | ||
137 | defcore get { argv argc } | |
138 | argc 3 < if mal-nil else argv cell+ cell+ @ endif | |
139 | argv cell+ @ \ key | |
140 | argv @ \ coll | |
141 | get ;; | |
142 | ||
143 | defcore contains? { argv argc } | |
144 | 0 | |
145 | argv cell+ @ \ key | |
146 | argv @ \ coll | |
147 | get 0 <> mal-bool ;; | |
e82947d0 C |
148 | |
149 | defcore nth ( argv[coll,i] argc ) | |
580c4eef C |
150 | drop dup @ to-list ( argv list ) |
151 | swap cell+ @ MalInt/int @ ( list i ) | |
152 | over MalList/count @ ( list i count ) | |
153 | 2dup >= if { i count } | |
154 | 0 0 | |
155 | new-str i int>str str-append s\" \040>= " count int>str | |
156 | s" nth out of bounds: " ...throw-str | |
157 | endif drop ( list i ) | |
158 | cells swap ( c-offset list ) | |
159 | MalList/start @ + @ ;; | |
e82947d0 C |
160 | |
161 | defcore first ( argv[coll] argc ) | |
162 | drop @ to-list | |
163 | dup MalList/count @ 0= if | |
164 | drop mal-nil | |
165 | else | |
166 | MalList/start @ @ | |
167 | endif ;; | |
168 | ||
169 | defcore rest ( argv[coll] argc ) | |
170 | drop @ to-list MalList/rest ;; | |
224e09ed C |
171 | |
172 | defcore meta ( argv[obj] argc ) | |
173 | drop @ mal-meta @ | |
174 | ?dup 0= if mal-nil endif ;; | |
175 | ||
176 | defcore with-meta ( argv[obj,meta] argc ) | |
177 | drop ( argv ) | |
178 | dup cell+ @ swap @ ( meta obj ) | |
179 | dup mal-type @ MalTypeType-struct @ ( meta obj obj-size ) | |
180 | dup allocate throw { new-obj } ( meta obj obj-size ) | |
181 | new-obj swap cmove ( meta ) | |
182 | new-obj mal-meta ! ( ) | |
183 | new-obj ;; | |
184 | ||
185 | defcore atom ( argv[val] argc ) | |
186 | drop @ Atom. ;; | |
187 | ||
188 | defcore deref ( argv[atom] argc ) | |
189 | drop @ Atom/val @ ;; | |
190 | ||
191 | defcore reset! ( argv[atom,val] argc ) | |
192 | drop dup cell+ @ ( argv val ) | |
193 | dup -rot swap @ Atom/val ! ;; | |
194 | ||
195 | defcore apply { argv argc -- val } | |
196 | \ argv is (fn args... more-args) | |
197 | argv argc 1- cells + @ to-list { more-args } | |
198 | argc 2 - { list0len } | |
199 | more-args MalList/count @ list0len + { final-argc } | |
200 | final-argc cells allocate throw { final-argv } | |
201 | argv cell+ final-argv list0len cells cmove | |
202 | more-args MalList/start @ final-argv list0len cells + final-argc list0len - cells cmove | |
203 | final-argv final-argc argv @ invoke ;; | |
204 | ||
6512bd80 C |
205 | defcore throw ( argv argc -- ) |
206 | drop @ to exception-object | |
207 | 1 throw ;; | |
224e09ed C |
208 | |
209 | defcore map? drop @ mal-type @ MalMap = mal-bool ;; | |
210 | defcore list? drop @ mal-type @ MalList = mal-bool ;; | |
211 | defcore vector? drop @ mal-type @ MalVector = mal-bool ;; | |
212 | defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;; | |
213 | defcore symbol? drop @ mal-type @ MalSymbol = mal-bool ;; | |
6512bd80 | 214 | defcore atom? drop @ mal-type @ Atom = mal-bool ;; |
224e09ed C |
215 | defcore true? drop @ mal-true = mal-bool ;; |
216 | defcore false? drop @ mal-false = mal-bool ;; | |
217 | defcore nil? drop @ mal-nil = mal-bool ;; | |
218 | ||
219 | defcore sequential? drop @ sequential? ;; | |
220 | ||
221 | defcore keyword drop @ unpack-str MalKeyword. ;; | |
6512bd80 C |
222 | defcore symbol drop @ unpack-str MalSymbol. ;; |
223 | ||
224 | defcore time-ms 2drop utime d>s 1000 / MalInt. ;; |