Branch data Line data Source code
1 : : /*
2 : : Extra femtoLisp builtin functions
3 : : */
4 : :
5 : : #include <stdlib.h>
6 : : #include <stdio.h>
7 : : #include <string.h>
8 : : #include <stdarg.h>
9 : : #include <assert.h>
10 : : #include <ctype.h>
11 : : #include <sys/types.h>
12 : : #include <sys/stat.h>
13 : : #include <errno.h>
14 : :
15 : : #include "flisp.h"
16 : :
17 : : #if !defined(_OS_WINDOWS_)
18 : : #include <sys/time.h>
19 : : #endif /* !_OS_WINDOWS_ */
20 : :
21 : : #ifdef __cplusplus
22 : : extern "C" {
23 : : #endif
24 : :
25 : 18349980 : size_t llength(value_t v)
26 : : {
27 : 18349980 : size_t n = 0;
28 [ + + ]: 88112400 : while (iscons(v)) {
29 : 69762400 : n++;
30 : 69762400 : v = cdr_(v);
31 : : }
32 : 18349980 : return n;
33 : : }
34 : :
35 : 10614860 : static value_t fl_nconc(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
36 : : {
37 [ + + ]: 10614860 : if (nargs == 0)
38 : 230842 : return fl_ctx->NIL;
39 : 10384020 : value_t lst, first=fl_ctx->NIL;
40 : 10384020 : value_t *pcdr = &first;
41 : : cons_t *c;
42 : 10384020 : uint32_t i=0;
43 : : while (1) {
44 : 31411000 : lst = args[i++];
45 [ + + ]: 31411000 : if (i >= nargs) break;
46 [ + + ]: 21026800 : if (iscons(lst)) {
47 : 8414020 : *pcdr = lst;
48 : 8414020 : c = (cons_t*)ptr(lst);
49 [ + + ]: 9551900 : while (iscons(c->cdr))
50 : 1137888 : c = (cons_t*)ptr(c->cdr);
51 : 8414020 : pcdr = &c->cdr;
52 : : }
53 [ - + ]: 12612880 : else if (lst != fl_ctx->NIL) {
54 : 0 : type_error(fl_ctx, "nconc", "cons", lst);
55 : : }
56 : : }
57 : 10384020 : *pcdr = lst;
58 : 10384020 : return first;
59 : : }
60 : :
61 : 4539480 : static value_t fl_assq(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
62 : : {
63 : 4539480 : argcount(fl_ctx, "assq", nargs, 2);
64 : 4539480 : value_t item = args[0];
65 : 4539480 : value_t v = args[1];
66 : : value_t bind;
67 : :
68 [ + + ]: 22711800 : while (iscons(v)) {
69 : 20860200 : bind = car_(v);
70 [ + - + + ]: 20860200 : if (iscons(bind) && car_(bind) == item)
71 : 2687960 : return bind;
72 : 18172240 : v = cdr_(v);
73 : : }
74 : 1851518 : return fl_ctx->F;
75 : : }
76 : :
77 : 282084000 : static value_t fl_memq(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
78 : : {
79 : 282084000 : argcount(fl_ctx, "memq", nargs, 2);
80 [ + + ]: 2319520000 : while (iscons(args[1])) {
81 : 2111400000 : cons_t *c = (cons_t*)ptr(args[1]);
82 [ + + ]: 2111400000 : if (c->car == args[0])
83 : 73965800 : return args[1];
84 : 2037440000 : args[1] = c->cdr;
85 : : }
86 : 208118000 : return fl_ctx->F;
87 : : }
88 : :
89 : 3245400 : static value_t fl_length(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
90 : : {
91 : 3245400 : argcount(fl_ctx, "length", nargs, 1);
92 : 3245400 : value_t a = args[0];
93 : : cvalue_t *cv;
94 [ - + ]: 3245400 : if (isvector(a)) {
95 : 0 : return fixnum(vector_size(a));
96 : : }
97 [ - + ]: 3245400 : else if (iscprim(a)) {
98 : 0 : cv = (cvalue_t*)ptr(a);
99 [ # # ]: 0 : if (cp_class(cv) == fl_ctx->bytetype)
100 : 0 : return fixnum(1);
101 [ # # ]: 0 : else if (cp_class(cv) == fl_ctx->wchartype)
102 : 0 : return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
103 : : }
104 [ + + ]: 3245400 : else if (iscvalue(a)) {
105 : 158040 : cv = (cvalue_t*)ptr(a);
106 [ + - ]: 158040 : if (cv_class(cv)->eltype != NULL)
107 : 158040 : return size_wrap(fl_ctx, cvalue_arraylen(a));
108 : : }
109 [ + + ]: 3087360 : else if (a == fl_ctx->NIL) {
110 : 502714 : return fixnum(0);
111 : : }
112 [ + - ]: 2584640 : else if (iscons(a)) {
113 : 2584640 : return fixnum(llength(a));
114 : : }
115 : 0 : type_error(fl_ctx, "length", "sequence", a);
116 : : }
117 : :
118 : 32 : static value_t fl_f_raise(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
119 : : {
120 : 32 : argcount(fl_ctx, "raise", nargs, 1);
121 : 32 : fl_raise(fl_ctx, args[0]);
122 : : }
123 : :
124 : 0 : static value_t fl_exit(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
125 : : {
126 [ # # ]: 0 : if (nargs > 0)
127 : 0 : exit(tofixnum(fl_ctx, args[0], "exit"));
128 : 0 : exit(0);
129 : : return fl_ctx->NIL;
130 : : }
131 : :
132 : 437542 : static value_t fl_symbol(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
133 : : {
134 : 437542 : argcount(fl_ctx, "symbol", nargs, 1);
135 [ - + ]: 437542 : if (!fl_isstring(fl_ctx, args[0]))
136 : 0 : type_error(fl_ctx, "symbol", "string", args[0]);
137 : 437542 : return symbol(fl_ctx, (char*)cvalue_data(args[0]));
138 : : }
139 : :
140 : 0 : static value_t fl_keywordp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
141 : : {
142 : 0 : argcount(fl_ctx, "keyword?", nargs, 1);
143 : 0 : return (issymbol(args[0]) &&
144 [ # # # # ]: 0 : iskeyword((symbol_t*)ptr(args[0]))) ? fl_ctx->T : fl_ctx->F;
145 : : }
146 : :
147 : 0 : static value_t fl_top_level_value(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
148 : : {
149 : 0 : argcount(fl_ctx, "top-level-value", nargs, 1);
150 : 0 : symbol_t *sym = tosymbol(fl_ctx, args[0], "top-level-value");
151 [ # # ]: 0 : if (sym->binding == UNBOUND)
152 : 0 : fl_raise(fl_ctx, fl_list2(fl_ctx, fl_ctx->UnboundError, args[0]));
153 : 0 : return sym->binding;
154 : : }
155 : :
156 : 0 : static value_t fl_set_top_level_value(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
157 : : {
158 : 0 : argcount(fl_ctx, "set-top-level-value!", nargs, 2);
159 : 0 : symbol_t *sym = tosymbol(fl_ctx, args[0], "set-top-level-value!");
160 [ # # ]: 0 : if (!isconstant(sym))
161 : 0 : sym->binding = args[1];
162 : 0 : return args[1];
163 : : }
164 : :
165 : 0 : static void global_env_list(fl_context_t *fl_ctx, symbol_t *root, value_t *pv)
166 : : {
167 [ # # ]: 0 : while (root != NULL) {
168 [ # # # # ]: 0 : if (root->name[0] != ':' && (root->binding != UNBOUND)) {
169 : 0 : *pv = fl_cons(fl_ctx, tagptr(root,TAG_SYM), *pv);
170 : : }
171 : 0 : global_env_list(fl_ctx, root->left, pv);
172 : 0 : root = root->right;
173 : : }
174 : 0 : }
175 : :
176 : 0 : value_t fl_global_env(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
177 : : {
178 : : (void)args;
179 : 0 : argcount(fl_ctx, "environment", nargs, 0);
180 : 0 : value_t lst = fl_ctx->NIL;
181 : 0 : fl_gc_handle(fl_ctx, &lst);
182 : 0 : global_env_list(fl_ctx, fl_ctx->symtab, &lst);
183 : 0 : fl_free_gc_handles(fl_ctx, 1);
184 : 0 : return lst;
185 : : }
186 : :
187 : 0 : static value_t fl_constantp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
188 : : {
189 : 0 : argcount(fl_ctx, "constant?", nargs, 1);
190 [ # # ]: 0 : if (issymbol(args[0]))
191 [ # # ]: 0 : return (isconstant((symbol_t*)ptr(args[0])) ? fl_ctx->T : fl_ctx->F);
192 [ # # ]: 0 : if (iscons(args[0])) {
193 [ # # ]: 0 : if (car_(args[0]) == fl_ctx->QUOTE)
194 : 0 : return fl_ctx->T;
195 : 0 : return fl_ctx->F;
196 : : }
197 : 0 : return fl_ctx->T;
198 : : }
199 : :
200 : 0 : static value_t fl_integer_valuedp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
201 : : {
202 : 0 : argcount(fl_ctx, "integer-valued?", nargs, 1);
203 : 0 : value_t v = args[0];
204 [ # # ]: 0 : if (isfixnum(v)) {
205 : 0 : return fl_ctx->T;
206 : : }
207 [ # # ]: 0 : else if (iscprim(v)) {
208 : 0 : numerictype_t nt = cp_numtype((cprim_t*)ptr(v));
209 [ # # ]: 0 : if (nt < T_FLOAT)
210 : 0 : return fl_ctx->T;
211 : 0 : void *data = cp_data((cprim_t*)ptr(v));
212 [ # # ]: 0 : if (nt == T_FLOAT) {
213 : 0 : float f = *(float*)data;
214 [ # # ]: 0 : if (f < 0) f = -f;
215 [ # # # # ]: 0 : if (f <= FLT_MAXINT && (float)(int32_t)f == f)
216 : 0 : return fl_ctx->T;
217 : : }
218 : : else {
219 [ # # ]: 0 : assert(nt == T_DOUBLE);
220 : 0 : double d = *(double*)data;
221 [ # # ]: 0 : if (d < 0) d = -d;
222 [ # # # # ]: 0 : if (d <= DBL_MAXINT && (double)(int64_t)d == d)
223 : 0 : return fl_ctx->T;
224 : : }
225 : : }
226 : 0 : return fl_ctx->F;
227 : : }
228 : :
229 : 111752 : static value_t fl_integerp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
230 : : {
231 : 111752 : argcount(fl_ctx, "integer?", nargs, 1);
232 : 111752 : value_t v = args[0];
233 : 121350 : return (isfixnum(v) ||
234 [ + + + + ]: 9598 : (iscprim(v) && cp_numtype((cprim_t*)ptr(v)) < T_FLOAT)) ?
235 [ + + ]: 121350 : fl_ctx->T : fl_ctx->F;
236 : : }
237 : :
238 : 0 : static value_t fl_fixnum(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
239 : : {
240 : 0 : argcount(fl_ctx, "fixnum", nargs, 1);
241 [ # # ]: 0 : if (isfixnum(args[0])) {
242 : 0 : return args[0];
243 : : }
244 [ # # ]: 0 : else if (iscprim(args[0])) {
245 : 0 : cprim_t *cp = (cprim_t*)ptr(args[0]);
246 : 0 : return fixnum(conv_to_ptrdiff(cp_data(cp), cp_numtype(cp)));
247 : : }
248 : 0 : type_error(fl_ctx, "fixnum", "number", args[0]);
249 : : }
250 : :
251 : 0 : static value_t fl_truncate(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
252 : : {
253 : 0 : argcount(fl_ctx, "truncate", nargs, 1);
254 [ # # ]: 0 : if (isfixnum(args[0]))
255 : 0 : return args[0];
256 [ # # ]: 0 : if (iscprim(args[0])) {
257 : 0 : cprim_t *cp = (cprim_t*)ptr(args[0]);
258 : 0 : void *data = cp_data(cp);
259 : 0 : numerictype_t nt = cp_numtype(cp);
260 : : double d;
261 [ # # ]: 0 : if (nt == T_FLOAT)
262 : 0 : d = (double)*(float*)data;
263 [ # # ]: 0 : else if (nt == T_DOUBLE)
264 : 0 : d = *(double*)data;
265 : : else
266 : 0 : return args[0];
267 [ # # ]: 0 : if (d > 0) {
268 [ # # ]: 0 : if (d > (double)U64_MAX)
269 : 0 : return args[0];
270 : 0 : return return_from_uint64(fl_ctx, (uint64_t)d);
271 : : }
272 [ # # # # ]: 0 : if (d > (double)S64_MAX || d < (double)S64_MIN)
273 : 0 : return args[0];
274 : 0 : return return_from_int64(fl_ctx, (int64_t)d);
275 : : }
276 : 0 : type_error(fl_ctx, "truncate", "number", args[0]);
277 : : }
278 : :
279 : 0 : static value_t fl_vector_alloc(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
280 : : {
281 : : fixnum_t i;
282 : : value_t f, v;
283 [ # # ]: 0 : if (nargs == 0)
284 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "vector.alloc: too few arguments");
285 : 0 : i = (fixnum_t)tosize(fl_ctx, args[0], "vector.alloc");
286 [ # # ]: 0 : if (i < 0)
287 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "vector.alloc: invalid size");
288 [ # # ]: 0 : if (nargs == 2)
289 : 0 : f = args[1];
290 : : else
291 : 0 : f = FL_UNSPECIFIED(fl_ctx);
292 : 0 : v = alloc_vector(fl_ctx, (unsigned)i, f==FL_UNSPECIFIED(fl_ctx));
293 [ # # ]: 0 : if (f != FL_UNSPECIFIED(fl_ctx)) {
294 : : int k;
295 [ # # ]: 0 : for(k=0; k < i; k++)
296 : 0 : vector_elt(v,k) = f;
297 : : }
298 : 0 : return v;
299 : : }
300 : :
301 : 0 : static value_t fl_time_now(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
302 : : {
303 : 0 : argcount(fl_ctx, "time.now", nargs, 0);
304 : : (void)args;
305 : 0 : return mk_double(fl_ctx, jl_clock_now());
306 : : }
307 : :
308 : 0 : static value_t fl_path_cwd(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
309 : : {
310 : : int err;
311 [ # # ]: 0 : if (nargs > 1)
312 : 0 : argcount(fl_ctx, "path.cwd", nargs, 1);
313 [ # # ]: 0 : if (nargs == 0) {
314 : : char buf[1024];
315 : 0 : size_t len = sizeof(buf);
316 : 0 : err = uv_cwd(buf, &len);
317 [ # # ]: 0 : if (err != 0)
318 : 0 : lerrorf(fl_ctx, fl_ctx->IOError, "path.cwd: could not get cwd: %s", uv_strerror(err));
319 : 0 : return string_from_cstrn(fl_ctx, buf, len);
320 : : }
321 : 0 : char *ptr = tostring(fl_ctx, args[0], "path.cwd");
322 : 0 : err = uv_chdir(ptr);
323 [ # # ]: 0 : if (err != 0)
324 : 0 : lerrorf(fl_ctx, fl_ctx->IOError, "path.cwd: could not cd to %s: %s", ptr, uv_strerror(err));
325 : 0 : return fl_ctx->T;
326 : : }
327 : :
328 : 0 : static value_t fl_path_exists(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
329 : : {
330 : 0 : argcount(fl_ctx, "path.exists?", nargs, 1);
331 : 0 : char *str = tostring(fl_ctx, args[0], "path.exists?");
332 : : struct stat sbuf;
333 [ # # ]: 0 : if (stat(str, &sbuf) == -1)
334 : 0 : return fl_ctx->F;
335 : 0 : return fl_ctx->T;
336 : : }
337 : :
338 : 0 : static value_t fl_os_getenv(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
339 : : {
340 : 0 : argcount(fl_ctx, "os.getenv", nargs, 1);
341 : 0 : char *name = tostring(fl_ctx, args[0], "os.getenv");
342 : 0 : char *val = getenv(name);
343 [ # # ]: 0 : if (val == NULL) return fl_ctx->F;
344 [ # # ]: 0 : if (*val == 0)
345 : 0 : return symbol_value(fl_ctx->emptystringsym);
346 : 0 : return cvalue_static_cstring(fl_ctx, val);
347 : : }
348 : :
349 : 0 : static value_t fl_os_setenv(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
350 : : {
351 : 0 : argcount(fl_ctx, "os.setenv", nargs, 2);
352 : 0 : char *name = tostring(fl_ctx, args[0], "os.setenv");
353 : : int result;
354 [ # # ]: 0 : if (args[1] == fl_ctx->F) {
355 : : #ifdef _OS_LINUX_
356 : 0 : result = unsetenv(name);
357 : : #elif defined(_OS_WINDOWS_)
358 : : result = SetEnvironmentVariable(name,NULL);
359 : : #else
360 : : (void)unsetenv(name);
361 : : result = 0;
362 : : #endif
363 : :
364 : : }
365 : : else {
366 : 0 : char *val = tostring(fl_ctx, args[1], "os.setenv");
367 : : #if defined (_OS_WINDOWS_)
368 : : result = SetEnvironmentVariable(name,val);
369 : : #else
370 : 0 : result = setenv(name, val, 1);
371 : : #endif
372 : : }
373 [ # # ]: 0 : if (result != 0)
374 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "os.setenv: invalid environment variable");
375 : 0 : return fl_ctx->T;
376 : : }
377 : :
378 : : extern void stringfuncs_init(fl_context_t *fl_ctx);
379 : : extern void table_init(fl_context_t *fl_ctx);
380 : : extern void iostream_init(fl_context_t *fl_ctx);
381 : :
382 : : static const builtinspec_t builtin_info[] = {
383 : : { "environment", fl_global_env },
384 : : { "constant?", fl_constantp },
385 : : { "top-level-value", fl_top_level_value },
386 : : { "set-top-level-value!", fl_set_top_level_value },
387 : : { "raise", fl_f_raise },
388 : : { "exit", fl_exit },
389 : : { "symbol", fl_symbol },
390 : : { "keyword?", fl_keywordp },
391 : :
392 : : { "fixnum", fl_fixnum },
393 : : { "truncate", fl_truncate },
394 : : { "integer?", fl_integerp },
395 : : { "integer-valued?", fl_integer_valuedp },
396 : : { "nconc", fl_nconc },
397 : : { "append!", fl_nconc },
398 : : { "assq", fl_assq },
399 : : { "memq", fl_memq },
400 : : { "length", fl_length },
401 : :
402 : : { "vector.alloc", fl_vector_alloc },
403 : :
404 : : { "time.now", fl_time_now },
405 : :
406 : : { "path.cwd", fl_path_cwd },
407 : : { "path.exists?", fl_path_exists },
408 : :
409 : : { "os.getenv", fl_os_getenv },
410 : : { "os.setenv", fl_os_setenv },
411 : : { NULL, NULL }
412 : : };
413 : :
414 : 30 : void builtins_init(fl_context_t *fl_ctx)
415 : : {
416 : 30 : assign_global_builtins(fl_ctx, builtin_info);
417 : 30 : stringfuncs_init(fl_ctx);
418 : 30 : table_init(fl_ctx);
419 : 30 : iostream_init(fl_ctx);
420 : 30 : }
421 : :
422 : : #ifdef __cplusplus
423 : : }
424 : : #endif
|
