Branch data Line data Source code
1 : : /*
2 : : femtoLisp
3 : :
4 : : a compact interpreter for a minimal lisp/scheme dialect
5 : :
6 : : characteristics:
7 : : * lexical scope, lisp-1
8 : : * unrestricted macros
9 : : * data types: 30-bit integer, symbol, pair, vector, char, string, table
10 : : iostream, procedure, low-level data types
11 : : * case-sensitive
12 : : * simple compacting copying garbage collector
13 : : * Scheme-style varargs (dotted formal argument lists)
14 : : * "human-readable" bytecode with self-hosted compiler
15 : :
16 : : extra features:
17 : : * circular structure can be printed and read
18 : : * #. read macro for eval-when-read and readably printing builtins
19 : : * read macros for backquote
20 : : * symbol character-escaping printer
21 : : * exceptions
22 : : * gensyms (can be usefully read back in, too)
23 : : * #| multiline comments |#, lots of other lexical syntax
24 : : * generic compare function, cyclic equal
25 : : * cvalues system providing C data types and a C FFI
26 : : * constructor notation for nicely printing arbitrary values
27 : :
28 : : by Jeff Bezanson (C) 2009
29 : : Distributed under the BSD License
30 : : */
31 : :
32 : : #include <stdlib.h>
33 : : #include <stdio.h>
34 : : #include <string.h>
35 : : #include <stdint.h>
36 : : #include <stdarg.h>
37 : : #include <assert.h>
38 : : #include <ctype.h>
39 : : #include <wctype.h>
40 : : #include <sys/types.h>
41 : : #include <locale.h>
42 : : #include <limits.h>
43 : : #include <errno.h>
44 : : #include <libgen.h> // defines dirname
45 : :
46 : : #include "platform.h"
47 : : #include "libsupport.h"
48 : : #include "flisp.h"
49 : : #include "opcodes.h"
50 : :
51 : : #ifdef __cplusplus
52 : : extern "C" {
53 : : #endif
54 : :
55 : : static const char *const builtin_names[] =
56 : : { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
57 : : NULL, NULL, NULL, NULL,
58 : : // predicates
59 : : "eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
60 : : "number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
61 : : "function?",
62 : :
63 : : // lists
64 : : "cons", "list", "car", "cdr", "set-car!", "set-cdr!",
65 : :
66 : : // execution
67 : : "apply",
68 : :
69 : : // arithmetic
70 : : "+", "-", "*", "/", "div0", "=", "<", "compare",
71 : :
72 : : // sequences
73 : : "vector", "aref", "aset!",
74 : : "", "", "" };
75 : :
76 : : #define ANYARGS -10000
77 : :
78 : : static const short builtin_arg_counts[] =
79 : : { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
80 : : 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
81 : : 2, ANYARGS, 1, 1, 2, 2,
82 : : -2,
83 : : ANYARGS, -1, ANYARGS, -1, 2, 2, 2, 2,
84 : : ANYARGS, 2, 3 };
85 : :
86 : : #define PUSH(fl_ctx, v) (fl_ctx->Stack[fl_ctx->SP++] = (v))
87 : : #define POP(fl_ctx) (fl_ctx->Stack[--fl_ctx->SP])
88 : : #define POPN(fl_ctx, n) (fl_ctx->SP-=(n))
89 : :
90 : : static value_t apply_cl(fl_context_t *fl_ctx, uint32_t nargs);
91 : : static value_t *alloc_words(fl_context_t *fl_ctx, int n);
92 : : static value_t relocate(fl_context_t *fl_ctx, value_t v);
93 : :
94 : : typedef struct _fl_readstate_t {
95 : : htable_t backrefs;
96 : : htable_t gensyms;
97 : : value_t source;
98 : : struct _fl_readstate_t *prev;
99 : : } fl_readstate_t;
100 : :
101 : 105218 : static void free_readstate(fl_readstate_t *rs)
102 : : {
103 : 105218 : htable_free(&rs->backrefs);
104 : 105218 : htable_free(&rs->gensyms);
105 : 105218 : }
106 : :
107 : : // error utilities ------------------------------------------------------------
108 : :
109 : : #define FL_TRY(fl_ctx) \
110 : : fl_exception_context_t _ctx; int l__tr, l__ca; \
111 : : _ctx.sp=fl_ctx->SP; _ctx.frame=fl_ctx->curr_frame; _ctx.rdst=fl_ctx->readstate; _ctx.prev=fl_ctx->exc_ctx; \
112 : : _ctx.ngchnd = fl_ctx->N_GCHND; fl_ctx->exc_ctx = &_ctx; \
113 : : if (!fl_setjmp(_ctx.buf)) \
114 : : for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx->exc_ctx=fl_ctx->exc_ctx->prev))
115 : :
116 : : #define FL_CATCH(fl_ctx) \
117 : : else \
118 : : for(l__ca=1; l__ca; l__ca=0, \
119 : : fl_ctx->lasterror=fl_ctx->NIL,fl_ctx->throwing_frame=0,fl_ctx->SP=_ctx.sp,fl_ctx->curr_frame=_ctx.frame)
120 : :
121 : 188014 : void fl_savestate(fl_context_t *fl_ctx, fl_exception_context_t *_ctx)
122 : : {
123 : 188014 : _ctx->sp = fl_ctx->SP;
124 : 188014 : _ctx->frame = fl_ctx->curr_frame;
125 : 188014 : _ctx->rdst = fl_ctx->readstate;
126 : 188014 : _ctx->prev = fl_ctx->exc_ctx;
127 : 188014 : _ctx->ngchnd = fl_ctx->N_GCHND;
128 : 188014 : }
129 : :
130 : 0 : void fl_restorestate(fl_context_t *fl_ctx, fl_exception_context_t *_ctx)
131 : : {
132 : 0 : fl_ctx->lasterror = fl_ctx->NIL;
133 : 0 : fl_ctx->throwing_frame = 0;
134 : 0 : fl_ctx->SP = _ctx->sp;
135 : 0 : fl_ctx->curr_frame = _ctx->frame;
136 : 0 : }
137 : :
138 : 32 : void fl_raise(fl_context_t *fl_ctx, value_t e)
139 : : {
140 : 32 : fl_ctx->lasterror = e;
141 : : // unwind read state
142 [ - + ]: 32 : while (fl_ctx->readstate != (fl_readstate_t*)fl_ctx->exc_ctx->rdst) {
143 : 0 : free_readstate(fl_ctx->readstate);
144 : 0 : fl_ctx->readstate = fl_ctx->readstate->prev;
145 : : }
146 [ + + ]: 32 : if (fl_ctx->throwing_frame == 0)
147 : 16 : fl_ctx->throwing_frame = fl_ctx->curr_frame;
148 : 32 : fl_ctx->N_GCHND = fl_ctx->exc_ctx->ngchnd;
149 : 32 : fl_exception_context_t *thisctx = fl_ctx->exc_ctx;
150 [ + - ]: 32 : if (fl_ctx->exc_ctx->prev) // don't throw past toplevel
151 : 32 : fl_ctx->exc_ctx = fl_ctx->exc_ctx->prev;
152 : 32 : fl_longjmp(thisctx->buf, 1);
153 : : }
154 : :
155 : 0 : static value_t make_error_msg(fl_context_t *fl_ctx, const char *format, va_list args)
156 : : {
157 : : char msgbuf[512];
158 : 0 : size_t len = vsnprintf(msgbuf, sizeof(msgbuf), format, args);
159 : 0 : return string_from_cstrn(fl_ctx, msgbuf, len);
160 : : }
161 : :
162 : 0 : void lerrorf(fl_context_t *fl_ctx, value_t e, const char *format, ...)
163 : : {
164 : : va_list args;
165 : 0 : PUSH(fl_ctx, e);
166 : 0 : va_start(args, format);
167 : 0 : value_t msg = make_error_msg(fl_ctx, format, args);
168 : 0 : va_end(args);
169 : :
170 : 0 : e = POP(fl_ctx);
171 : 0 : fl_raise(fl_ctx, fl_list2(fl_ctx, e, msg));
172 : : }
173 : :
174 : 0 : void lerror(fl_context_t *fl_ctx, value_t e, const char *msg)
175 : : {
176 : 0 : PUSH(fl_ctx, e);
177 : 0 : value_t m = cvalue_static_cstring(fl_ctx, msg);
178 : 0 : e = POP(fl_ctx);
179 : 0 : fl_raise(fl_ctx, fl_list2(fl_ctx, e, m));
180 : : }
181 : :
182 : 0 : void type_error(fl_context_t *fl_ctx, const char *fname, const char *expected, value_t got)
183 : : {
184 : 0 : fl_raise(fl_ctx, fl_listn(fl_ctx, 4, fl_ctx->TypeError, symbol(fl_ctx, fname), symbol(fl_ctx, expected), got));
185 : : }
186 : :
187 : 0 : void bounds_error(fl_context_t *fl_ctx, const char *fname, value_t arr, value_t ind)
188 : : {
189 : 0 : fl_raise(fl_ctx, fl_listn(fl_ctx, 4, fl_ctx->BoundsError, symbol(fl_ctx, fname), arr, ind));
190 : : }
191 : :
192 : : // safe cast operators --------------------------------------------------------
193 : :
194 : : #define isstring(v) fl_isstring(fl_ctx, v)
195 : : #define SAFECAST_OP(type,ctype,cnvt) \
196 : : ctype to##type(fl_context_t *fl_ctx, value_t v, const char *fname) \
197 : : { \
198 : : if (is##type(v)) \
199 : : return (ctype)cnvt(v); \
200 : : type_error(fl_ctx, fname, #type, v); \
201 : : }
202 [ + - ]: 90044200 : SAFECAST_OP(cons, cons_t*, ptr)
203 [ + - ]: 63942 : SAFECAST_OP(symbol,symbol_t*,ptr)
204 [ + - ]: 28295000 : SAFECAST_OP(fixnum,fixnum_t, numval)
205 [ + - ]: 4871900 : SAFECAST_OP(string,char*, cvalue_data)
206 : : #undef isstring
207 : :
208 : : // symbol table ---------------------------------------------------------------
209 : :
210 : 237564 : int fl_is_keyword_name(const char *str, size_t len)
211 : : {
212 [ + + + + : 237564 : return len>1 && ((str[0] == ':' || str[len-1] == ':') && str[1] != '\0');
+ + + - ]
213 : : }
214 : :
215 : : #define CHECK_ALIGN8(p) assert((((uintptr_t)(p))&0x7)==0 && "flisp requires malloc to return 8-aligned pointers")
216 : :
217 : 237564 : static symbol_t *mk_symbol(const char *str)
218 : : {
219 : : symbol_t *sym;
220 : 237564 : size_t len = strlen(str);
221 : :
222 : 237564 : sym = (symbol_t*)malloc((offsetof(symbol_t,name)+len+1+7)&-8);
223 : : // TODO: if sym == NULL
224 [ - + ]: 237564 : CHECK_ALIGN8(sym);
225 : 237564 : sym->left = sym->right = NULL;
226 : 237564 : sym->flags = 0;
227 [ + + ]: 237564 : if (fl_is_keyword_name(str, len)) {
228 : 446 : value_t s = tagptr(sym, TAG_SYM);
229 : 446 : setc(s, s);
230 : 446 : sym->flags |= 0x2;
231 : : }
232 : : else {
233 : 237118 : sym->binding = UNBOUND;
234 : : }
235 : 237564 : sym->type = NULL;
236 : 237564 : sym->dlcache = NULL;
237 : 237564 : sym->hash = memhash32(str, len)^0xAAAAAAAA;
238 : 237564 : strcpy(&sym->name[0], str);
239 : 237564 : return sym;
240 : : }
241 : :
242 : 15117240 : static symbol_t **symtab_lookup(symbol_t **ptree, const char *str)
243 : : {
244 : : int x;
245 : :
246 [ + + ]: 244782000 : while (*ptree != NULL) {
247 : 244544000 : x = strcmp(str, (*ptree)->name);
248 [ + + ]: 244544000 : if (x == 0)
249 : 14879660 : return ptree;
250 [ + + ]: 229664000 : if (x < 0)
251 : 106279000 : ptree = &(*ptree)->left;
252 : : else
253 : 123385400 : ptree = &(*ptree)->right;
254 : : }
255 : 237564 : return ptree;
256 : : }
257 : :
258 : 15117240 : value_t symbol(fl_context_t *fl_ctx, const char *str)
259 : : {
260 : 15117240 : symbol_t **pnode = symtab_lookup(&fl_ctx->symtab, str);
261 [ + + ]: 15117240 : if (*pnode == NULL)
262 : 237564 : *pnode = mk_symbol(str);
263 : 15117240 : return tagptr(*pnode, TAG_SYM);
264 : : }
265 : :
266 : 0 : value_t fl_gensym(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
267 : : {
268 : : #ifdef MEMDEBUG2
269 : : fl_ctx->gsnameno = 1-fl_ctx->gsnameno;
270 : : char *n = uint2str(fl_ctx->gsname[fl_ctx->gsnameno]+1, sizeof(fl_ctx->gsname[0])-1, fl_ctx->gensym_ctr++, 10);
271 : : *(--n) = 'g';
272 : : return tagptr(mk_symbol(n), TAG_SYM);
273 : : #else
274 : 0 : argcount(fl_ctx, "gensym", nargs, 0);
275 : : (void)args;
276 : 0 : gensym_t *gs = (gensym_t*)alloc_words(fl_ctx, sizeof(gensym_t)/sizeof(void*));
277 : 0 : gs->id = fl_ctx->gensym_ctr++;
278 : 0 : gs->binding = UNBOUND;
279 : 0 : gs->isconst = 0;
280 : 0 : gs->type = NULL;
281 : 0 : return tagptr(gs, TAG_SYM);
282 : : #endif
283 : : }
284 : :
285 : 26584200 : int fl_isgensym(fl_context_t *fl_ctx, value_t v)
286 : : {
287 [ + - - + : 26584200 : return isgensym(fl_ctx, v);
- - ]
288 : : }
289 : :
290 : 0 : static value_t fl_gensymp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
291 : : {
292 : 0 : argcount(fl_ctx, "gensym?", nargs, 1);
293 [ # # # # : 0 : return isgensym(fl_ctx, args[0]) ? fl_ctx->T : fl_ctx->F;
# # ]
294 : : }
295 : :
296 : 39466200 : char *symbol_name(fl_context_t *fl_ctx, value_t v)
297 : : {
298 : : #ifndef MEMDEBUG2
299 [ - + - - ]: 39466200 : if (ismanaged(fl_ctx, v)) {
300 : 0 : gensym_t *gs = (gensym_t*)ptr(v);
301 : 0 : fl_ctx->gsnameno = 1-fl_ctx->gsnameno;
302 : 0 : char *n = uint2str(fl_ctx->gsname[fl_ctx->gsnameno]+1, sizeof(fl_ctx->gsname[0])-1, gs->id, 10);
303 : 0 : *(--n) = 'g';
304 : 0 : return n;
305 : : }
306 : : #else
307 : : (void)fl_ctx;
308 : : #endif
309 : 39466200 : return ((symbol_t*)ptr(v))->name;
310 : : }
311 : :
312 : : // conses ---------------------------------------------------------------------
313 : :
314 : : #ifdef MEMDEBUG2
315 : : #define GC_INTERVAL 100000
316 : : #endif
317 : :
318 : : void gc(fl_context_t *fl_ctx, int mustgrow);
319 : :
320 : 199011600 : static value_t mk_cons(fl_context_t *fl_ctx)
321 : : {
322 : : cons_t *c;
323 : :
324 : : #ifdef MEMDEBUG2
325 : : if (fl_ctx->n_allocd > GC_INTERVAL)
326 : : gc(fl_ctx, 0);
327 : : c = (cons_t*)((void**)malloc(3*sizeof(void*)) + 1);
328 : : // TODO: if c == NULL
329 : : CHECK_ALIGN8(c);
330 : : ((void**)c)[-1] = fl_ctx->tochain;
331 : : fl_ctx->tochain = c;
332 : : fl_ctx->n_allocd += sizeof(cons_t);
333 : : #else
334 [ + + ]: 199011600 : if (__unlikely(fl_ctx->curheap > fl_ctx->lim))
335 : 906 : gc(fl_ctx, 0);
336 : 199011600 : c = (cons_t*)fl_ctx->curheap;
337 : 199011600 : fl_ctx->curheap += sizeof(cons_t);
338 : : #endif
339 : 199011600 : return tagptr(c, TAG_CONS);
340 : : }
341 : :
342 : 260222000 : static value_t *alloc_words(fl_context_t *fl_ctx, int n)
343 : : {
344 : : value_t *first;
345 : :
346 [ - + ]: 260222000 : assert(n > 0);
347 : 260222000 : n = LLT_ALIGN(n, 2); // only allocate multiples of 2 words
348 : : #ifdef MEMDEBUG2
349 : : if (fl_ctx->n_allocd > GC_INTERVAL)
350 : : gc(fl_ctx, 0);
351 : : first = (value_t*)malloc((n+1)*sizeof(value_t)) + 1;
352 : : // TODO: if first == NULL
353 : : CHECK_ALIGN8(first);
354 : : first[-1] = (value_t)fl_ctx->tochain;
355 : : fl_ctx->tochain = first;
356 : : fl_ctx->n_allocd += (n*sizeof(value_t));
357 : : #else
358 [ + + ]: 260222000 : if (__unlikely((value_t*)fl_ctx->curheap > ((value_t*)fl_ctx->lim)+2-n)) {
359 : 2256 : gc(fl_ctx, 0);
360 [ - + ]: 2256 : while ((value_t*)fl_ctx->curheap > ((value_t*)fl_ctx->lim)+2-n) {
361 : 0 : gc(fl_ctx, 1);
362 : : }
363 : : }
364 : 260222000 : first = (value_t*)fl_ctx->curheap;
365 : 260222000 : fl_ctx->curheap += (n*sizeof(value_t));
366 : : #endif
367 : 260222000 : return first;
368 : : }
369 : :
370 : : // allocate n consecutive conses
371 : : #ifndef MEMDEBUG2
372 : : #define cons_reserve(fl_ctx, n) tagptr(alloc_words(fl_ctx, (n)*2), TAG_CONS)
373 : : #endif
374 : :
375 : : #ifndef MEMDEBUG2
376 : : #define cons_index(fl_ctx, c) (((cons_t*)ptr(c))-((cons_t*)fl_ctx->fromspace))
377 : : #endif
378 : :
379 : : #ifdef MEMDEBUG2
380 : : #define ismarked(fl_ctx, c) ((((value_t*)ptr(c))[-1]&1) != 0)
381 : : #define mark_cons(fl_ctx, c) ((((value_t*)ptr(c))[-1]) |= 1)
382 : : #define unmark_cons(fl_ctx, c) ((((value_t*)ptr(c))[-1]) &= (~(value_t)1))
383 : : #else
384 : : #define ismarked(fl_ctx, c) bitvector_get(fl_ctx->consflags, cons_index(fl_ctx, c))
385 : : #define mark_cons(fl_ctx, c) bitvector_set(fl_ctx->consflags, cons_index(fl_ctx, c), 1)
386 : : #define unmark_cons(fl_ctx, c) bitvector_set(fl_ctx->consflags, cons_index(fl_ctx, c), 0)
387 : : #endif
388 : :
389 : 1070936 : value_t alloc_vector(fl_context_t *fl_ctx, size_t n, int init)
390 : : {
391 [ - + ]: 1070936 : if (n == 0) return fl_ctx->the_empty_vector;
392 : 1070936 : value_t *c = alloc_words(fl_ctx, n+1);
393 : 1070936 : value_t v = tagptr(c, TAG_VECTOR);
394 : 1070936 : vector_setsize(v, n);
395 [ + + ]: 1070936 : if (init) {
396 : : unsigned int i;
397 [ + + ]: 687210 : for(i=0; i < n; i++)
398 : 619860 : vector_elt(v, i) = FL_UNSPECIFIED(fl_ctx);
399 : : }
400 : 1070936 : return v;
401 : : }
402 : :
403 : : // cvalues --------------------------------------------------------------------
404 : :
405 : : #include "cvalues.c"
406 : : #include "types.c"
407 : :
408 : : // print ----------------------------------------------------------------------
409 : :
410 : : static int isnumtok(fl_context_t *fl_ctx, char *tok, value_t *pval);
411 : : static inline int symchar(char c);
412 : :
413 : : #include "print.c"
414 : :
415 : : // collector ------------------------------------------------------------------
416 : :
417 : 21926600 : void fl_gc_handle(fl_context_t *fl_ctx, value_t *pv)
418 : : {
419 [ - + ]: 21926600 : if (fl_ctx->N_GCHND >= FL_N_GC_HANDLES)
420 : 0 : lerror(fl_ctx, fl_ctx->OutOfMemoryError, "out of gc handles");
421 : 21926600 : fl_ctx->GCHandleStack[fl_ctx->N_GCHND++] = pv;
422 : 21926600 : }
423 : :
424 : 13991860 : void fl_free_gc_handles(fl_context_t *fl_ctx, uint32_t n)
425 : : {
426 [ - + ]: 13991860 : assert(fl_ctx->N_GCHND >= n);
427 : 13991860 : fl_ctx->N_GCHND -= n;
428 : 13991860 : }
429 : :
430 : 79423800 : value_t relocate_lispvalue(fl_context_t *fl_ctx, value_t v)
431 : : {
432 : 79423800 : return relocate(fl_ctx, v);
433 : : }
434 : :
435 : 75693200 : static void trace_globals(fl_context_t *fl_ctx, symbol_t *root)
436 : : {
437 [ + + ]: 151382000 : while (root != NULL) {
438 [ + + ]: 75688800 : if (root->binding != UNBOUND)
439 : 4738600 : root->binding = relocate(fl_ctx, root->binding);
440 : 75688800 : trace_globals(fl_ctx, root->left);
441 : 75688800 : root = root->right;
442 : : }
443 : 75693200 : }
444 : :
445 : 133297000 : static value_t relocate(fl_context_t *fl_ctx, value_t v)
446 : : {
447 : : value_t a, d, nc, first, *pcdr;
448 : 133297000 : uintptr_t t = tag(v);
449 : :
450 [ + + ]: 133297000 : if (t == TAG_CONS) {
451 : : // iterative implementation allows arbitrarily long cons chains
452 : 9052300 : pcdr = &first;
453 : : do {
454 [ + + ]: 43323200 : if ((a=car_(v)) == TAG_FWD) {
455 : 1284884 : *pcdr = cdr_(v);
456 : 1284884 : return first;
457 : : }
458 : : #ifdef MEMDEBUG2
459 : : *pcdr = nc = mk_cons(fl_ctx);
460 : : #else
461 : 42038200 : *pcdr = nc = tagptr((cons_t*)fl_ctx->curheap, TAG_CONS);
462 : 42038200 : fl_ctx->curheap += sizeof(cons_t);
463 : : #endif
464 : 42038200 : d = cdr_(v);
465 : 42038200 : car_(v) = TAG_FWD; cdr_(v) = nc;
466 [ + + + + : 42038200 : if ((tag(a)&3) == 0 || !ismanaged(fl_ctx, a))
- + ]
467 : 31320600 : car_(nc) = a;
468 : : else
469 : 10717580 : car_(nc) = relocate(fl_ctx, a);
470 : 42038200 : pcdr = &cdr_(nc);
471 : 42038200 : v = d;
472 [ + + ]: 42038200 : } while (iscons(v));
473 [ + + ]: 7767420 : *pcdr = (d==fl_ctx->NIL) ? fl_ctx->NIL : relocate(fl_ctx, d);
474 : 7767420 : return first;
475 : : }
476 : :
477 [ + + + + : 124244600 : if ((t&3) == 0 || !ismanaged(fl_ctx, v)) return v;
- + ]
478 [ + + ]: 35926200 : if (isforwarded(v)) return forwardloc(v);
479 : :
480 [ + + ]: 30984800 : if (t == TAG_VECTOR) {
481 : : // N.B.: 0-length vectors secretly have space for a first element
482 : 6996320 : size_t i, sz = vector_size(v);
483 [ - + ]: 6996320 : if (vector_elt(v,-1) & 0x1) {
484 : : // grown vector
485 : 0 : nc = relocate(fl_ctx, vector_elt(v,0));
486 : 0 : forward(v, nc);
487 : : }
488 : : else {
489 : 6996320 : nc = tagptr(alloc_words(fl_ctx, sz+1), TAG_VECTOR);
490 : 6996320 : vector_setsize(nc, sz);
491 : 6996320 : a = vector_elt(v,0);
492 : 6996320 : forward(v, nc);
493 [ + + ]: 6996320 : if (sz > 0) {
494 : 6991860 : vector_elt(nc,0) = relocate(fl_ctx, a);
495 [ + + ]: 38012200 : for(i=1; i < sz; i++) {
496 : 31020400 : a = vector_elt(v,i);
497 [ + + + + : 31020400 : if ((tag(a)&3) == 0 || !ismanaged(fl_ctx, a))
- + ]
498 : 23478200 : vector_elt(nc,i) = a;
499 : : else
500 : 7542240 : vector_elt(nc,i) = relocate(fl_ctx, a);
501 : : }
502 : : }
503 : : }
504 : 6996320 : return nc;
505 : : }
506 [ + + ]: 23988600 : else if (t == TAG_CPRIM) {
507 : 6503120 : cprim_t *pcp = (cprim_t*)ptr(v);
508 : 6503120 : size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size);
509 : 6503120 : cprim_t *ncp = (cprim_t*)alloc_words(fl_ctx, nw);
510 [ + + ]: 19509340 : while (nw--)
511 : 13006220 : ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw];
512 : 6503120 : nc = tagptr(ncp, TAG_CPRIM);
513 : 6503120 : forward(v, nc);
514 : 6503120 : return nc;
515 : : }
516 [ + + ]: 17485420 : else if (t == TAG_CVALUE) {
517 : 9920320 : return cvalue_relocate(fl_ctx, v);
518 : : }
519 [ + - ]: 7565080 : else if (t == TAG_FUNCTION) {
520 : 7565080 : function_t *fn = (function_t*)ptr(v);
521 : 7565080 : function_t *nfn = (function_t*)alloc_words(fl_ctx, 4);
522 : 7565080 : nfn->bcode = fn->bcode;
523 : 7565080 : nfn->vals = fn->vals;
524 : 7565080 : nc = tagptr(nfn, TAG_FUNCTION);
525 : 7565080 : forward(v, nc);
526 : 7565080 : nfn->env = relocate(fl_ctx, fn->env);
527 : 7565080 : nfn->vals = relocate(fl_ctx, nfn->vals);
528 : 7565080 : nfn->bcode = relocate(fl_ctx, nfn->bcode);
529 : 7565080 : nfn->name = fn->name;
530 : 7565080 : return nc;
531 : : }
532 [ # # ]: 0 : else if (t == TAG_SYM) {
533 : 0 : gensym_t *gs = (gensym_t*)ptr(v);
534 : 0 : gensym_t *ng = (gensym_t*)alloc_words(fl_ctx, sizeof(gensym_t)/sizeof(void*));
535 : 0 : ng->id = gs->id;
536 : 0 : ng->binding = gs->binding;
537 : 0 : ng->isconst = 0;
538 : 0 : nc = tagptr(ng, TAG_SYM);
539 : 0 : forward(v, nc);
540 [ # # ]: 0 : if (ng->binding != UNBOUND)
541 : 0 : ng->binding = relocate(fl_ctx, ng->binding);
542 : 0 : return nc;
543 : : }
544 : 0 : return v;
545 : : }
546 : :
547 : 4474 : void gc(fl_context_t *fl_ctx, int mustgrow)
548 : : {
549 : : void *temp;
550 : : uint32_t i, f, top;
551 : : fl_readstate_t *rs;
552 : : #ifdef MEMDEBUG2
553 : : temp = fl_ctx->tochain;
554 : : fl_ctx->tochain = NULL;
555 : : fl_ctx->n_allocd = -100000000000LL;
556 : : #else
557 [ - + ]: 4474 : size_t hsz = fl_ctx->gc_grew ? fl_ctx->heapsize*2 : fl_ctx->heapsize;
558 : : #ifdef MEMDEBUG
559 : : fl_ctx->tospace = LLT_ALLOC(hsz);
560 : : #endif
561 : 4474 : fl_ctx->curheap = fl_ctx->tospace;
562 : 4474 : fl_ctx->lim = fl_ctx->curheap + hsz - sizeof(cons_t);
563 : : #endif
564 : :
565 [ - + ]: 4474 : if (fl_ctx->throwing_frame > fl_ctx->curr_frame) {
566 : 0 : top = fl_ctx->throwing_frame - 3;
567 : 0 : f = fl_ctx->Stack[fl_ctx->throwing_frame-3];
568 : : }
569 : : else {
570 : 4474 : top = fl_ctx->SP;
571 : 4474 : f = fl_ctx->curr_frame;
572 : : }
573 : : while (1) {
574 [ + + ]: 980008 : for (i=f; i < top; i++)
575 : 851592 : fl_ctx->Stack[i] = relocate(fl_ctx, fl_ctx->Stack[i]);
576 [ + + ]: 128416 : if (f == 0) break;
577 : 123942 : top = f - 3;
578 : 123942 : f = fl_ctx->Stack[f-3];
579 : : }
580 [ + + ]: 7100 : for (i=0; i < fl_ctx->N_GCHND; i++)
581 : 2626 : *fl_ctx->GCHandleStack[i] = relocate(fl_ctx, *fl_ctx->GCHandleStack[i]);
582 : 4474 : trace_globals(fl_ctx, fl_ctx->symtab);
583 : 4474 : relocate_typetable(fl_ctx);
584 : 4474 : rs = fl_ctx->readstate;
585 [ + + ]: 4478 : while (rs) {
586 [ + + ]: 132 : for(i=0; i < rs->backrefs.size; i++)
587 : 128 : rs->backrefs.table[i] = (void*)relocate(fl_ctx, (value_t)rs->backrefs.table[i]);
588 [ + + ]: 132 : for(i=0; i < rs->gensyms.size; i++)
589 : 128 : rs->gensyms.table[i] = (void*)relocate(fl_ctx, (value_t)rs->gensyms.table[i]);
590 : 4 : rs->source = relocate(fl_ctx, rs->source);
591 : 4 : rs = rs->prev;
592 : : }
593 : 4474 : fl_ctx->lasterror = relocate(fl_ctx, fl_ctx->lasterror);
594 : 4474 : fl_ctx->memory_exception_value = relocate(fl_ctx, fl_ctx->memory_exception_value);
595 : 4474 : fl_ctx->the_empty_vector = relocate(fl_ctx, fl_ctx->the_empty_vector);
596 : :
597 : 4474 : sweep_finalizers(fl_ctx);
598 : :
599 : : #ifdef MEMDEBUG2
600 : : while (temp != NULL) {
601 : : void *next = ((void**)temp)[-1];
602 : : free(&((void**)temp)[-1]);
603 : : temp = next;
604 : : }
605 : : fl_ctx->n_allocd = 0;
606 : : #else
607 : : #ifdef VERBOSEGC
608 : : printf("GC: found %d/%d live conses\n",
609 : : (fl_ctx->curheap-fl_ctx->tospace)/sizeof(cons_t), fl_ctx->heapsize/sizeof(cons_t));
610 : : #endif
611 : :
612 : 4474 : temp = fl_ctx->tospace;
613 : 4474 : fl_ctx->tospace = fl_ctx->fromspace;
614 : 4474 : fl_ctx->fromspace = (unsigned char*)temp;
615 : :
616 : : // if we're using > 80% of the space, resize tospace so we have
617 : : // more space to fill next time. if we grew tospace last time,
618 : : // grow the other half of the heap this time to catch up.
619 [ + - + - ]: 4474 : if (fl_ctx->gc_grew || mustgrow
620 : : #ifdef MEMDEBUG
621 : : // GC more often
622 : : || ((fl_ctx->lim-fl_ctx->curheap) < (int)(fl_ctx->heapsize/128))
623 : : #else
624 [ - + ]: 4474 : || ((fl_ctx->lim-fl_ctx->curheap) < (int)(fl_ctx->heapsize/5))
625 : : #endif
626 : : ) {
627 : 0 : temp = LLT_REALLOC(fl_ctx->tospace, fl_ctx->heapsize*2);
628 [ # # ]: 0 : if (temp == NULL)
629 : 0 : fl_raise(fl_ctx, fl_ctx->memory_exception_value);
630 : 0 : fl_ctx->tospace = (unsigned char*)temp;
631 [ # # ]: 0 : if (fl_ctx->gc_grew) {
632 : 0 : fl_ctx->heapsize*=2;
633 : 0 : temp = bitvector_resize(fl_ctx->consflags, 0, fl_ctx->heapsize/sizeof(cons_t), 1);
634 [ # # ]: 0 : if (temp == NULL)
635 : 0 : fl_raise(fl_ctx, fl_ctx->memory_exception_value);
636 : 0 : fl_ctx->consflags = (uint32_t*)temp;
637 : : }
638 : 0 : fl_ctx->gc_grew = !fl_ctx->gc_grew;
639 : : }
640 : : #ifdef MEMDEBUG
641 : : LLT_FREE(fl_ctx->tospace);
642 : : #endif
643 [ - + ]: 4474 : if ((value_t*)fl_ctx->curheap > ((value_t*)fl_ctx->lim)-2) {
644 : : // all data was live; gc again and grow heap.
645 : : // but also always leave at least 4 words available, so a closure
646 : : // can be allocated without an extra check.
647 : 0 : gc(fl_ctx, 0);
648 : : }
649 : : #endif
650 : 4474 : }
651 : :
652 : 0 : static void grow_stack(fl_context_t *fl_ctx)
653 : : {
654 : 0 : size_t newsz = fl_ctx->N_STACK + (fl_ctx->N_STACK>>1);
655 : 0 : value_t *ns = (value_t*)realloc(fl_ctx->Stack, newsz*sizeof(value_t));
656 [ # # ]: 0 : if (ns == NULL)
657 : 0 : lerror(fl_ctx, fl_ctx->OutOfMemoryError, "stack overflow");
658 : 0 : fl_ctx->Stack = ns;
659 : 0 : fl_ctx->N_STACK = newsz;
660 : 0 : }
661 : :
662 : : // utils ----------------------------------------------------------------------
663 : :
664 : : // apply function with n args on the stack
665 : 233192000 : static value_t _applyn(fl_context_t *fl_ctx, uint32_t n)
666 : : {
667 : 233192000 : value_t f = fl_ctx->Stack[fl_ctx->SP-n-1];
668 : 233192000 : uint32_t saveSP = fl_ctx->SP;
669 : : value_t v;
670 [ + + + - ]: 233192000 : if (iscbuiltin(fl_ctx, f)) {
671 : 203858 : v = ((builtin_t*)ptr(f))[3](fl_ctx, &fl_ctx->Stack[fl_ctx->SP-n], n);
672 : : }
673 [ + - + + ]: 232988000 : else if (isfunction(f)) {
674 : 232354000 : v = apply_cl(fl_ctx, n);
675 : : }
676 [ + - + - ]: 1267904 : else if (isbuiltin(f)) {
677 : 633952 : value_t tab = symbol_value(fl_ctx->builtins_table_sym);
678 : 633952 : fl_ctx->Stack[fl_ctx->SP-n-1] = vector_elt(tab, uintval(f));
679 : 633952 : v = apply_cl(fl_ctx, n);
680 : : }
681 : : else {
682 : 0 : type_error(fl_ctx, "apply", "function", f);
683 : : }
684 : 233192000 : fl_ctx->SP = saveSP;
685 : 233192000 : return v;
686 : : }
687 : :
688 : 88470 : value_t fl_apply(fl_context_t *fl_ctx, value_t f, value_t l)
689 : : {
690 : 88470 : value_t v = l;
691 : 88470 : uint32_t n = fl_ctx->SP;
692 : :
693 : 88470 : PUSH(fl_ctx, f);
694 [ + + ]: 785130 : while (iscons(v)) {
695 [ - + ]: 696660 : if (fl_ctx->SP >= fl_ctx->N_STACK)
696 : 0 : grow_stack(fl_ctx);
697 : 696660 : PUSH(fl_ctx, car_(v));
698 : 696660 : v = cdr_(v);
699 : : }
700 : 88470 : n = fl_ctx->SP - n - 1;
701 : 88470 : v = _applyn(fl_ctx, n);
702 : 88470 : POPN(fl_ctx, n+1);
703 : 88470 : return v;
704 : : }
705 : :
706 : 1106700 : value_t fl_applyn(fl_context_t *fl_ctx, uint32_t n, value_t f, ...)
707 : : {
708 : : va_list ap;
709 : 1106700 : va_start(ap, f);
710 : : size_t i;
711 : :
712 : 1106700 : PUSH(fl_ctx, f);
713 [ - + ]: 1106700 : while (fl_ctx->SP+n > fl_ctx->N_STACK)
714 : 0 : grow_stack(fl_ctx);
715 [ + + ]: 4454920 : for(i=0; i < n; i++) {
716 : 3348240 : value_t a = va_arg(ap, value_t);
717 : 3348240 : PUSH(fl_ctx, a);
718 : : }
719 : 1106700 : value_t v = _applyn(fl_ctx, n);
720 : 1106700 : POPN(fl_ctx, n+1);
721 : 1106700 : va_end(ap);
722 : 1106700 : return v;
723 : : }
724 : :
725 : 0 : value_t fl_listn(fl_context_t *fl_ctx, size_t n, ...)
726 : : {
727 : : va_list ap;
728 : 0 : va_start(ap, n);
729 : 0 : uint32_t si = fl_ctx->SP;
730 : : size_t i;
731 : :
732 [ # # ]: 0 : while (fl_ctx->SP+n > fl_ctx->N_STACK)
733 : 0 : grow_stack(fl_ctx);
734 [ # # ]: 0 : for(i=0; i < n; i++) {
735 : 0 : value_t a = va_arg(ap, value_t);
736 : 0 : PUSH(fl_ctx, a);
737 : : }
738 : : #ifdef MEMDEBUG2
739 : : si = fl_ctx->SP-1;
740 : : value_t l = fl_ctx->NIL;
741 : : for(i=0; i < n; i++) {
742 : : l = fl_cons(fl_ctx, fl_ctx->Stack[si--], l);
743 : : }
744 : : POPN(fl_ctx, n);
745 : : va_end(ap);
746 : : return l;
747 : : #else
748 : 0 : cons_t *c = (cons_t*)alloc_words(fl_ctx, n*2);
749 : 0 : cons_t *l = c;
750 [ # # ]: 0 : for(i=0; i < n; i++) {
751 : 0 : c->car = fl_ctx->Stack[si++];
752 : 0 : c->cdr = tagptr(c+1, TAG_CONS);
753 : 0 : c++;
754 : : }
755 : 0 : (c-1)->cdr = fl_ctx->NIL;
756 : 0 : POPN(fl_ctx, n);
757 : 0 : va_end(ap);
758 : 0 : return tagptr(l, TAG_CONS);
759 : : #endif
760 : : }
761 : :
762 : 1453202 : value_t fl_list2(fl_context_t *fl_ctx, value_t a, value_t b)
763 : : {
764 : 1453202 : PUSH(fl_ctx, a);
765 : 1453202 : PUSH(fl_ctx, b);
766 : : #ifdef MEMDEBUG2
767 : : fl_ctx->Stack[fl_ctx->SP-1] = fl_cons(fl_ctx, b, fl_ctx->NIL);
768 : : a = fl_cons(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1]);
769 : : POPN(fl_ctx, 2);
770 : : return a;
771 : : #else
772 : 1453202 : cons_t *c = (cons_t*)alloc_words(fl_ctx, 4);
773 : 1453202 : b = POP(fl_ctx);
774 : 1453202 : a = POP(fl_ctx);
775 : 1453202 : c[0].car = a;
776 : 1453202 : c[0].cdr = tagptr(c+1, TAG_CONS);
777 : 1453202 : c[1].car = b;
778 : 1453202 : c[1].cdr = fl_ctx->NIL;
779 : 1453202 : return tagptr(c, TAG_CONS);
780 : : #endif
781 : : }
782 : :
783 : 14448640 : value_t fl_cons(fl_context_t *fl_ctx, value_t a, value_t b)
784 : : {
785 : 14448640 : PUSH(fl_ctx, a);
786 : 14448640 : PUSH(fl_ctx, b);
787 : 14448640 : value_t c = mk_cons(fl_ctx);
788 : 14448640 : cdr_(c) = POP(fl_ctx);
789 : 14448640 : car_(c) = POP(fl_ctx);
790 : 14448640 : return c;
791 : : }
792 : :
793 : 56354600 : int fl_isnumber(fl_context_t *fl_ctx, value_t v)
794 : : {
795 [ + + ]: 56354600 : if (isfixnum(v)) return 1;
796 [ + + ]: 48588200 : if (iscprim(v)) {
797 : 1171562 : cprim_t *c = (cprim_t*)ptr(v);
798 : 1171562 : return c->type != fl_ctx->wchartype;
799 : : }
800 : 47416800 : return 0;
801 : : }
802 : :
803 : : // read -----------------------------------------------------------------------
804 : :
805 : : #include "read.c"
806 : :
807 : : // equal ----------------------------------------------------------------------
808 : :
809 : : #include "equal.c"
810 : :
811 : : // eval -----------------------------------------------------------------------
812 : :
813 : : #define list(fl_ctx, a,n) _list(fl_ctx, (a), (n), 0)
814 : :
815 : 44972400 : static value_t _list(fl_context_t *fl_ctx, value_t *args, uint32_t nargs, int star)
816 : : {
817 : : cons_t *c;
818 : : int i;
819 : : value_t v;
820 : : #ifdef MEMDEBUG2
821 : : value_t n;
822 : : i = nargs-1;
823 : : if (star) {
824 : : n = mk_cons(fl_ctx);
825 : : c = (cons_t*)ptr(n);
826 : : c->car = args[i-1];
827 : : c->cdr = args[i];
828 : : i -= 2;
829 : : v = n;
830 : : }
831 : : else {
832 : : v = fl_ctx->NIL;
833 : : }
834 : : PUSH(fl_ctx, v);
835 : : for(; i >= 0; i--) {
836 : : n = mk_cons(fl_ctx);
837 : : c = (cons_t*)ptr(n);
838 : : c->car = args[i];
839 : : c->cdr = fl_ctx->Stack[fl_ctx->SP-1];
840 : : fl_ctx->Stack[fl_ctx->SP-1] = n;
841 : : }
842 : : v = POP(fl_ctx);
843 : : #else
844 : 44972400 : v = cons_reserve(fl_ctx, nargs);
845 : 44972400 : c = (cons_t*)ptr(v);
846 [ + + ]: 135803400 : for(i=0; i < nargs; i++) {
847 : 90830800 : c->car = args[i];
848 : 90830800 : c->cdr = tagptr(c+1, TAG_CONS);
849 : 90830800 : c++;
850 : : }
851 [ + + ]: 44972400 : if (star)
852 : 795132 : (c-2)->cdr = (c-1)->car;
853 : : else
854 : 44177400 : (c-1)->cdr = fl_ctx->NIL;
855 : : #endif
856 : 44972400 : return v;
857 : : }
858 : :
859 : 5724260 : static value_t copy_list(fl_context_t *fl_ctx, value_t L)
860 : : {
861 [ + + ]: 5724260 : if (!iscons(L))
862 : 1740706 : return fl_ctx->NIL;
863 : 3983560 : PUSH(fl_ctx, fl_ctx->NIL);
864 : 3983560 : PUSH(fl_ctx, L);
865 : 3983560 : value_t *plcons = &fl_ctx->Stack[fl_ctx->SP-2];
866 : 3983560 : value_t *pL = &fl_ctx->Stack[fl_ctx->SP-1];
867 : : value_t c;
868 : 3983560 : c = mk_cons(fl_ctx); PUSH(fl_ctx, c); // save first cons
869 : 3983560 : car_(c) = car_(*pL);
870 : 3983560 : cdr_(c) = fl_ctx->NIL;
871 : 3983560 : *plcons = c;
872 : 3983560 : *pL = cdr_(*pL);
873 [ + + ]: 11033200 : while (iscons(*pL)) {
874 : 7049640 : c = mk_cons(fl_ctx);
875 : 7049640 : car_(c) = car_(*pL);
876 : 7049640 : cdr_(c) = fl_ctx->NIL;
877 : 7049640 : cdr_(*plcons) = c;
878 : 7049640 : *plcons = c;
879 : 7049640 : *pL = cdr_(*pL);
880 : : }
881 : 3983560 : c = POP(fl_ctx); // first cons
882 : 3983560 : POPN(fl_ctx, 2);
883 : 3983560 : return c;
884 : : }
885 : :
886 : 2718140 : static value_t do_trycatch(fl_context_t *fl_ctx)
887 : : {
888 : 2718140 : uint32_t saveSP = fl_ctx->SP;
889 : : value_t v;
890 : 2718140 : value_t thunk = fl_ctx->Stack[fl_ctx->SP-2];
891 : 2718140 : fl_ctx->Stack[fl_ctx->SP-2] = fl_ctx->Stack[fl_ctx->SP-1];
892 : 2718140 : fl_ctx->Stack[fl_ctx->SP-1] = thunk;
893 : :
894 [ + + + + ]: 5436260 : FL_TRY(fl_ctx) {
895 : 2718140 : v = apply_cl(fl_ctx, 0);
896 : : }
897 [ + + ]: 48 : FL_CATCH(fl_ctx) {
898 : 32 : v = fl_ctx->Stack[saveSP-2];
899 : 32 : PUSH(fl_ctx, v);
900 : 32 : PUSH(fl_ctx, fl_ctx->lasterror);
901 : 32 : v = apply_cl(fl_ctx, 1);
902 : : }
903 : 2718120 : fl_ctx->SP = saveSP;
904 : 2718120 : return v;
905 : : }
906 : :
907 : : /*
908 : : argument layout on stack is
909 : : |--required args--|--opt args--|--kw args--|--rest args...
910 : : */
911 : 0 : static uint32_t process_keys(fl_context_t *fl_ctx, value_t kwtable,
912 : : uint32_t nreq, uint32_t nkw, uint32_t nopt,
913 : : uint32_t bp, uint32_t nargs, int va)
914 : : {
915 : : uintptr_t n;
916 : 0 : uint32_t extr = nopt+nkw;
917 : 0 : uint32_t ntot = nreq+extr;
918 : 0 : value_t *args = (value_t*)alloca(extr*sizeof(value_t));
919 : : value_t v;
920 : 0 : uint32_t i, a = 0, nrestargs;
921 : 0 : value_t s1 = fl_ctx->Stack[fl_ctx->SP-1];
922 : 0 : value_t s3 = fl_ctx->Stack[fl_ctx->SP-3];
923 : 0 : value_t s4 = fl_ctx->Stack[fl_ctx->SP-4];
924 [ # # ]: 0 : if (nargs < nreq)
925 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too few arguments");
926 [ # # ]: 0 : for (i=0; i < extr; i++) args[i] = UNBOUND;
927 [ # # ]: 0 : for (i=nreq; i < nargs; i++) {
928 : 0 : v = fl_ctx->Stack[bp+i];
929 [ # # # # ]: 0 : if (issymbol(v) && iskeyword((symbol_t*)ptr(v)))
930 : 0 : break;
931 [ # # ]: 0 : if (a >= nopt)
932 : 0 : goto no_kw;
933 : 0 : args[a++] = v;
934 : : }
935 [ # # ]: 0 : if (i >= nargs) goto no_kw;
936 : : // now process keywords
937 : 0 : n = vector_size(kwtable)/2;
938 : : do {
939 : 0 : i++;
940 [ # # ]: 0 : if (i >= nargs)
941 : 0 : lerrorf(fl_ctx, fl_ctx->ArgError, "keyword %s requires an argument",
942 : : symbol_name(fl_ctx, v));
943 : 0 : value_t hv = fixnum(((symbol_t*)ptr(v))->hash);
944 : 0 : uintptr_t x = 2*(labs(numval(hv)) % n);
945 [ # # ]: 0 : if (vector_elt(kwtable, x) == v) {
946 : 0 : uintptr_t idx = numval(vector_elt(kwtable, x+1));
947 [ # # ]: 0 : assert(idx < nkw);
948 : 0 : idx += nopt;
949 [ # # ]: 0 : if (args[idx] == UNBOUND) {
950 : : // if duplicate key, keep first value
951 : 0 : args[idx] = fl_ctx->Stack[bp+i];
952 : : }
953 : : }
954 : : else {
955 : 0 : lerrorf(fl_ctx, fl_ctx->ArgError, "unsupported keyword %s", symbol_name(fl_ctx, v));
956 : : }
957 : 0 : i++;
958 [ # # ]: 0 : if (i >= nargs) break;
959 : 0 : v = fl_ctx->Stack[bp+i];
960 [ # # # # ]: 0 : } while (issymbol(v) && iskeyword((symbol_t*)ptr(v)));
961 : 0 : no_kw:
962 : 0 : nrestargs = nargs - i;
963 [ # # # # ]: 0 : if (!va && nrestargs > 0)
964 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too many arguments");
965 : 0 : nargs = ntot + nrestargs;
966 [ # # ]: 0 : if (nrestargs)
967 : 0 : memmove(&fl_ctx->Stack[bp+ntot], &fl_ctx->Stack[bp+i], nrestargs*sizeof(value_t));
968 : 0 : memcpy(&fl_ctx->Stack[bp+nreq], args, extr*sizeof(value_t));
969 : 0 : fl_ctx->SP = bp + nargs;
970 [ # # ]: 0 : assert(fl_ctx->SP < fl_ctx->N_STACK-4);
971 : 0 : PUSH(fl_ctx, s4);
972 : 0 : PUSH(fl_ctx, s3);
973 : 0 : PUSH(fl_ctx, nargs);
974 : 0 : PUSH(fl_ctx, s1);
975 : 0 : fl_ctx->curr_frame = fl_ctx->SP;
976 : 0 : return nargs;
977 : : }
978 : :
979 : : #if BYTE_ORDER == BIG_ENDIAN
980 : : #define GET_INT32(a) \
981 : : ((int32_t) \
982 : : ((((int32_t)a[0])<<0) | \
983 : : (((int32_t)a[1])<<8) | \
984 : : (((int32_t)a[2])<<16) | \
985 : : (((int32_t)a[3])<<24)))
986 : : #define GET_INT16(a) \
987 : : ((int16_t) \
988 : : ((((int16_t)a[0])<<0) | \
989 : : (((int16_t)a[1])<<8)))
990 : : #define PUT_INT32(a,i) jl_store_unaligned_i32((void*)a,
991 : : (uint32_t)bswap_32((int32_t)(i)))
992 : : #else
993 : : #define GET_INT32(a) (int32_t)jl_load_unaligned_i32((void*)a)
994 : : #define GET_INT16(a) (int16_t)jl_load_unaligned_i16((void*)a)
995 : : #define PUT_INT32(a,i) jl_store_unaligned_i32((void*)a, (uint32_t)(i))
996 : : #endif
997 : : #define SWAP_INT32(a) (*(int32_t*)(a) = bswap_32(*(int32_t*)(a)))
998 : : #define SWAP_INT16(a) (*(int16_t*)(a) = bswap_16(*(int16_t*)(a)))
999 : :
1000 : : #ifdef USE_COMPUTED_GOTO
1001 : : #define OP(x) L_##x:
1002 : : #define NEXT_OP goto *vm_labels[*ip++]
1003 : : #else
1004 : : #define OP(x) case x:
1005 : : #define NEXT_OP goto next_op
1006 : : #endif
1007 : :
1008 : : /*
1009 : : stack on entry: <func> <nargs args...>
1010 : : caller's responsibility:
1011 : : - put the stack in this state
1012 : : - provide arg count
1013 : : - respect tail position
1014 : : - restore fl_ctx->SP
1015 : :
1016 : : callee's responsibility:
1017 : : - check arg counts
1018 : : - allocate vararg array
1019 : : - push closed env, set up new environment
1020 : : */
1021 : 235714000 : JL_EXTENSION static value_t apply_cl(fl_context_t *fl_ctx, uint32_t nargs)
1022 : : {
1023 : : VM_LABELS;
1024 : : VM_APPLY_LABELS;
1025 : 235714000 : uint32_t top_frame = fl_ctx->curr_frame;
1026 : : // frame variables
1027 : 235714000 : uint32_t n=0;
1028 : : uint32_t bp;
1029 : : const uint8_t *ip;
1030 : : fixnum_t s, hi;
1031 : :
1032 : : // temporary variables (not necessary to preserve across calls)
1033 : : #ifndef USE_COMPUTED_GOTO
1034 : : uint32_t op;
1035 : : #endif
1036 : : uint32_t i;
1037 : : symbol_t *sym;
1038 : : #define fl_apply_c fl_ctx->apply_c
1039 : : #define fl_apply_pv fl_ctx->apply_pv
1040 : : #define fl_apply_accum fl_ctx->apply_accum
1041 : : #define fl_apply_func fl_ctx->apply_func
1042 : : #define fl_apply_v fl_ctx->apply_v
1043 : : #define fl_apply_e fl_ctx->apply_e
1044 : :
1045 : 1580796000 : apply_cl_top:
1046 : 1580796000 : fl_apply_func = fl_ctx->Stack[fl_ctx->SP-nargs-1];
1047 : 1580796000 : ip = (uint8_t*)cv_data((cvalue_t*)ptr(fn_bcode(fl_apply_func)));
1048 : : #ifndef MEMDEBUG2
1049 [ - + - - ]: 1580796000 : assert(!ismanaged(fl_ctx, (uintptr_t)ip));
1050 : : #endif
1051 [ - + ]: 1580796000 : while (fl_ctx->SP+GET_INT32(ip) > fl_ctx->N_STACK) {
1052 : 0 : grow_stack(fl_ctx);
1053 : : }
1054 : 1580796000 : ip += 4;
1055 : :
1056 : 1580796000 : bp = fl_ctx->SP-nargs;
1057 : 1580796000 : PUSH(fl_ctx, fn_env(fl_apply_func));
1058 : 1580796000 : PUSH(fl_ctx, fl_ctx->curr_frame);
1059 : 1580796000 : PUSH(fl_ctx, nargs);
1060 : 1580796000 : fl_ctx->SP++;//PUSH(fl_ctx, 0); //ip
1061 : 1580796000 : fl_ctx->curr_frame = fl_ctx->SP;
1062 : :
1063 : : {
1064 : : #ifdef USE_COMPUTED_GOTO
1065 : : {
1066 : 1580796000 : NEXT_OP;
1067 : : #else
1068 : : next_op:
1069 : : op = *ip++;
1070 : : dispatch:
1071 : : switch (op) {
1072 : : #endif
1073 : 1454542000 : OP(OP_ARGC)
1074 : 1454542000 : n = *ip++;
1075 : 1454542000 : do_argc:
1076 [ - + ]: 1454542000 : if (nargs != n) {
1077 [ # # ]: 0 : if (nargs > n)
1078 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too many arguments");
1079 : : else
1080 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too few arguments");
1081 : : }
1082 : 1454542000 : NEXT_OP;
1083 : 1474728 : OP(OP_VARGC)
1084 : 1474728 : i = *ip++;
1085 : 1474728 : do_vargc:
1086 : 1474728 : s = (fixnum_t)nargs - (fixnum_t)i;
1087 [ + + ]: 1474728 : if (s > 0) {
1088 : 1350972 : fl_apply_v = list(fl_ctx, &fl_ctx->Stack[bp+i], s);
1089 : 1350972 : fl_ctx->Stack[bp+i] = fl_apply_v;
1090 [ + + ]: 1350972 : if (s > 1) {
1091 : 1174512 : fl_ctx->Stack[bp+i+1] = fl_ctx->Stack[bp+nargs+0];
1092 : 1174512 : fl_ctx->Stack[bp+i+2] = fl_ctx->Stack[bp+nargs+1];
1093 : 1174512 : fl_ctx->Stack[bp+i+3] = i+1;
1094 : 1174512 : fl_ctx->Stack[bp+i+4] = 0;
1095 : 1174512 : fl_ctx->SP = bp+i+5;
1096 : 1174512 : fl_ctx->curr_frame = fl_ctx->SP;
1097 : : }
1098 : : }
1099 [ - + ]: 123756 : else if (s < 0) {
1100 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too few arguments");
1101 : : }
1102 : : else {
1103 : 123756 : fl_ctx->SP++;
1104 : 123756 : fl_ctx->Stack[fl_ctx->SP-2] = i+1;
1105 : 123756 : fl_ctx->Stack[fl_ctx->SP-3] = fl_ctx->Stack[fl_ctx->SP-4];
1106 : 123756 : fl_ctx->Stack[fl_ctx->SP-4] = fl_ctx->Stack[fl_ctx->SP-5];
1107 : 123756 : fl_ctx->Stack[fl_ctx->SP-5] = fl_ctx->NIL;
1108 : 123756 : fl_ctx->curr_frame = fl_ctx->SP;
1109 : : }
1110 : 1474728 : nargs = i+1;
1111 : 1474728 : NEXT_OP;
1112 : 0 : OP(OP_LARGC)
1113 : 0 : n = GET_INT32(ip); ip+=4;
1114 : 0 : goto do_argc;
1115 : 0 : OP(OP_LVARGC)
1116 : 0 : i = GET_INT32(ip); ip+=4;
1117 : 0 : goto do_vargc;
1118 : 141903000 : OP(OP_BRBOUND)
1119 : 141903000 : i = GET_INT32(ip); ip+=4;
1120 : 141903000 : fl_apply_v = fl_ctx->Stack[bp+i];
1121 [ + + ]: 141903000 : if (fl_apply_v != UNBOUND) PUSH(fl_ctx, fl_ctx->T);
1122 : 16939320 : else PUSH(fl_ctx, fl_ctx->F);
1123 : 141903000 : NEXT_OP;
1124 : 1167784000 : OP(OP_DUP) fl_ctx->SP++; fl_ctx->Stack[fl_ctx->SP-1] = fl_ctx->Stack[fl_ctx->SP-2]; NEXT_OP;
1125 : 1123390000 : OP(OP_POP) POPN(fl_ctx, 1); NEXT_OP;
1126 : 817594000 : OP(OP_TCALL)
1127 : 817594000 : n = *ip++; // nargs
1128 : 823898000 : do_tcall:
1129 : 823898000 : fl_apply_func = fl_ctx->Stack[fl_ctx->SP-n-1];
1130 [ + + ]: 823898000 : if (tag(fl_apply_func) == TAG_FUNCTION) {
1131 [ + - ]: 516182000 : if (fl_apply_func > (N_BUILTINS<<3)) {
1132 : 516182000 : fl_ctx->curr_frame = fl_ctx->Stack[fl_ctx->curr_frame-3];
1133 [ + + ]: 2204420000 : for(s=-1; s < (fixnum_t)n; s++)
1134 : 1688242000 : fl_ctx->Stack[bp+s] = fl_ctx->Stack[fl_ctx->SP-n+s];
1135 : 516182000 : fl_ctx->SP = bp+n;
1136 : 516182000 : nargs = n;
1137 : 516182000 : goto apply_cl_top;
1138 : : }
1139 : : else {
1140 : 0 : i = uintval(fl_apply_func);
1141 [ # # ]: 0 : if (i <= OP_ASET) {
1142 : 0 : s = builtin_arg_counts[i];
1143 [ # # ]: 0 : if (s >= 0)
1144 : 0 : argcount(fl_ctx, builtin_names[i], n, s);
1145 [ # # # # ]: 0 : else if (s != ANYARGS && (signed)n < -s)
1146 : 0 : argcount(fl_ctx, builtin_names[i], n, -s);
1147 : : // remove function arg
1148 [ # # ]: 0 : for(s=fl_ctx->SP-n-1; s < (int)fl_ctx->SP-1; s++)
1149 : 0 : fl_ctx->Stack[s] = fl_ctx->Stack[s+1];
1150 : 0 : fl_ctx->SP--;
1151 : : #ifdef USE_COMPUTED_GOTO
1152 [ # # ]: 0 : if (i == OP_APPLY)
1153 : 0 : goto apply_tapply;
1154 : 0 : goto *vm_apply_labels[i];
1155 : : #else
1156 : : switch (i) {
1157 : : case OP_LIST: goto apply_list;
1158 : : case OP_VECTOR: goto apply_vector;
1159 : : case OP_APPLY: goto apply_tapply;
1160 : : case OP_ADD: goto apply_add;
1161 : : case OP_SUB: goto apply_sub;
1162 : : case OP_MUL: goto apply_mul;
1163 : : case OP_DIV: goto apply_div;
1164 : : default:
1165 : : op = (uint8_t)i;
1166 : : goto dispatch;
1167 : : }
1168 : : #endif
1169 : : }
1170 : : }
1171 : : }
1172 [ + - + - ]: 307716000 : else if (iscbuiltin(fl_ctx, fl_apply_func)) {
1173 : 307716000 : s = fl_ctx->SP;
1174 : 307716000 : fl_apply_v = ((builtin_t)(uintptr_t)(((void**)ptr(fl_apply_func))[3]))(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-n], n);
1175 : 307716000 : fl_ctx->SP = s-n;
1176 : 307716000 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1177 : 307716000 : NEXT_OP;
1178 : : }
1179 : 0 : type_error(fl_ctx, "apply", "function", fl_apply_func);
1180 : : // WARNING: repeated code ahead
1181 : 1213308000 : OP(OP_CALL)
1182 : 1213308000 : n = *ip++; // nargs
1183 : 1214424000 : do_call:
1184 : 1214424000 : fl_apply_func = fl_ctx->Stack[fl_ctx->SP-n-1];
1185 [ + + ]: 1214424000 : if (tag(fl_apply_func) == TAG_FUNCTION) {
1186 [ + + ]: 833556000 : if (fl_apply_func > (N_BUILTINS<<3)) {
1187 : 828900000 : fl_ctx->Stack[fl_ctx->curr_frame-1] = (uintptr_t)ip;
1188 : 828900000 : nargs = n;
1189 : 828900000 : goto apply_cl_top;
1190 : : }
1191 : : else {
1192 : 4655720 : i = uintval(fl_apply_func);
1193 [ + - ]: 4655720 : if (i <= OP_ASET) {
1194 : 4655720 : s = builtin_arg_counts[i];
1195 [ + - ]: 4655720 : if (s >= 0)
1196 : 4655720 : argcount(fl_ctx, builtin_names[i], n, s);
1197 [ # # # # ]: 0 : else if (s != ANYARGS && (signed)n < -s)
1198 : 0 : argcount(fl_ctx, builtin_names[i], n, -s);
1199 : : // remove function arg
1200 [ + + ]: 13297580 : for(s=fl_ctx->SP-n-1; s < (int)fl_ctx->SP-1; s++)
1201 : 8641860 : fl_ctx->Stack[s] = fl_ctx->Stack[s+1];
1202 : 4655720 : fl_ctx->SP--;
1203 : : #ifdef USE_COMPUTED_GOTO
1204 : 4655720 : goto *vm_apply_labels[i];
1205 : : #else
1206 : : switch (i) {
1207 : : case OP_LIST: goto apply_list;
1208 : : case OP_VECTOR: goto apply_vector;
1209 : : case OP_APPLY: goto apply_apply;
1210 : : case OP_ADD: goto apply_add;
1211 : : case OP_SUB: goto apply_sub;
1212 : : case OP_MUL: goto apply_mul;
1213 : : case OP_DIV: goto apply_div;
1214 : : default:
1215 : : op = (uint8_t)i;
1216 : : goto dispatch;
1217 : : }
1218 : : #endif
1219 : : }
1220 : : }
1221 : : }
1222 [ + - + - ]: 380868000 : else if (iscbuiltin(fl_ctx, fl_apply_func)) {
1223 : 380868000 : s = fl_ctx->SP;
1224 : 380868000 : fl_apply_v = ((builtin_t)(uintptr_t)(((void**)ptr(fl_apply_func))[3]))(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-n], n);
1225 : 380868000 : fl_ctx->SP = s-n;
1226 : 380868000 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1227 : 380868000 : NEXT_OP;
1228 : : }
1229 : 0 : type_error(fl_ctx, "apply", "function", fl_apply_func);
1230 : 0 : OP(OP_TCALLL) n = GET_INT32(ip); ip+=4; goto do_tcall;
1231 : 0 : OP(OP_CALLL) n = GET_INT32(ip); ip+=4; goto do_call;
1232 : 60090200 : OP(OP_JMP) ip += (intptr_t)GET_INT16(ip); NEXT_OP;
1233 : 2246520000 : OP(OP_BRF)
1234 : 2246520000 : fl_apply_v = POP(fl_ctx);
1235 [ + + ]: 2246520000 : if (fl_apply_v == fl_ctx->F) ip += (intptr_t)GET_INT16(ip);
1236 : 700256000 : else ip += 2;
1237 : 2246520000 : NEXT_OP;
1238 : 764242000 : OP(OP_BRT)
1239 : 764242000 : fl_apply_v = POP(fl_ctx);
1240 [ + + ]: 764242000 : if (fl_apply_v != fl_ctx->F) ip += (intptr_t)GET_INT16(ip);
1241 : 496388000 : else ip += 2;
1242 : 764242000 : NEXT_OP;
1243 : 0 : OP(OP_JMPL) ip += (intptr_t)GET_INT32(ip); NEXT_OP;
1244 : 0 : OP(OP_BRFL)
1245 : 0 : fl_apply_v = POP(fl_ctx);
1246 [ # # ]: 0 : if (fl_apply_v == fl_ctx->F) ip += (intptr_t)GET_INT32(ip);
1247 : 0 : else ip += 4;
1248 : 0 : NEXT_OP;
1249 : 0 : OP(OP_BRTL)
1250 : 0 : fl_apply_v = POP(fl_ctx);
1251 [ # # ]: 0 : if (fl_apply_v != fl_ctx->F) ip += (intptr_t)GET_INT32(ip);
1252 : 0 : else ip += 4;
1253 : 0 : NEXT_OP;
1254 : 164846400 : OP(OP_BRNE)
1255 [ + + ]: 164846400 : if (fl_ctx->Stack[fl_ctx->SP-2] != fl_ctx->Stack[fl_ctx->SP-1]) ip += (intptr_t)GET_INT16(ip);
1256 : 10434160 : else ip += 2;
1257 : 164846400 : POPN(fl_ctx, 2);
1258 : 164846400 : NEXT_OP;
1259 : 0 : OP(OP_BRNEL)
1260 [ # # ]: 0 : if (fl_ctx->Stack[fl_ctx->SP-2] != fl_ctx->Stack[fl_ctx->SP-1]) ip += (intptr_t)GET_INT32(ip);
1261 : 0 : else ip += 4;
1262 : 0 : POPN(fl_ctx, 2);
1263 : 0 : NEXT_OP;
1264 : 60373200 : OP(OP_BRNN)
1265 : 60373200 : fl_apply_v = POP(fl_ctx);
1266 [ + + ]: 60373200 : if (fl_apply_v != fl_ctx->NIL) ip += (intptr_t)GET_INT16(ip);
1267 : 18727260 : else ip += 2;
1268 : 60373200 : NEXT_OP;
1269 : 0 : OP(OP_BRNNL)
1270 : 0 : fl_apply_v = POP(fl_ctx);
1271 [ # # ]: 0 : if (fl_apply_v != fl_ctx->NIL) ip += (intptr_t)GET_INT32(ip);
1272 : 0 : else ip += 4;
1273 : 0 : NEXT_OP;
1274 : 316756 : OP(OP_BRN)
1275 : 316756 : fl_apply_v = POP(fl_ctx);
1276 [ + + ]: 316756 : if (fl_apply_v == fl_ctx->NIL) ip += (intptr_t)GET_INT16(ip);
1277 : 12 : else ip += 2;
1278 : 316756 : NEXT_OP;
1279 : 0 : OP(OP_BRNL)
1280 : 0 : fl_apply_v = POP(fl_ctx);
1281 [ # # ]: 0 : if (fl_apply_v == fl_ctx->NIL) ip += (intptr_t)GET_INT32(ip);
1282 : 0 : else ip += 4;
1283 : 0 : NEXT_OP;
1284 : 1064614000 : OP(OP_RET)
1285 : 1064614000 : fl_apply_v = POP(fl_ctx);
1286 : 1064614000 : fl_ctx->SP = fl_ctx->curr_frame;
1287 : 1064614000 : fl_ctx->curr_frame = fl_ctx->Stack[fl_ctx->SP-3];
1288 [ + + ]: 1064614000 : if (fl_ctx->curr_frame == top_frame) return fl_apply_v;
1289 : 828900000 : fl_ctx->SP -= (4+nargs);
1290 : 828900000 : ip = (uint8_t*)fl_ctx->Stack[fl_ctx->curr_frame-1];
1291 : 828900000 : nargs = fl_ctx->Stack[fl_ctx->curr_frame-2];
1292 : 828900000 : bp = fl_ctx->curr_frame - 4 - nargs;
1293 : 828900000 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1294 : 828900000 : NEXT_OP;
1295 : :
1296 : 299326000 : OP(OP_EQ)
1297 [ + + ]: 299326000 : fl_ctx->Stack[fl_ctx->SP-2] = ((fl_ctx->Stack[fl_ctx->SP-2] == fl_ctx->Stack[fl_ctx->SP-1]) ? fl_ctx->T : fl_ctx->F);
1298 : 299326000 : POPN(fl_ctx, 1); NEXT_OP;
1299 : 287462000 : OP(OP_EQV)
1300 [ + + ]: 287462000 : if (fl_ctx->Stack[fl_ctx->SP-2] == fl_ctx->Stack[fl_ctx->SP-1]) {
1301 : 13797300 : fl_apply_v = fl_ctx->T;
1302 : : }
1303 [ + + - + ]: 273664000 : else if (!leafp(fl_ctx->Stack[fl_ctx->SP-2]) || !leafp(fl_ctx->Stack[fl_ctx->SP-1])) {
1304 : 744 : fl_apply_v = fl_ctx->F;
1305 : : }
1306 : : else {
1307 [ + + ]: 273664000 : fl_apply_v = (compare_(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1], 1)==0 ? fl_ctx->T : fl_ctx->F);
1308 : : }
1309 : 287462000 : fl_ctx->Stack[fl_ctx->SP-2] = fl_apply_v; POPN(fl_ctx, 1);
1310 : 287462000 : NEXT_OP;
1311 : 6351520 : OP(OP_EQUAL)
1312 [ + + ]: 6351520 : if (fl_ctx->Stack[fl_ctx->SP-2] == fl_ctx->Stack[fl_ctx->SP-1]) {
1313 : 1526696 : fl_apply_v = fl_ctx->T;
1314 : : }
1315 : : else {
1316 [ + + ]: 4824820 : fl_apply_v = (compare_(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1], 1)==0 ? fl_ctx->T : fl_ctx->F);
1317 : : }
1318 : 6351520 : fl_ctx->Stack[fl_ctx->SP-2] = fl_apply_v; POPN(fl_ctx, 1);
1319 : 6351520 : NEXT_OP;
1320 : 493478000 : OP(OP_PAIRP)
1321 [ + + ]: 493478000 : fl_ctx->Stack[fl_ctx->SP-1] = (iscons(fl_ctx->Stack[fl_ctx->SP-1]) ? fl_ctx->T : fl_ctx->F); NEXT_OP;
1322 : 328432000 : OP(OP_ATOMP)
1323 [ + + ]: 328432000 : fl_ctx->Stack[fl_ctx->SP-1] = (iscons(fl_ctx->Stack[fl_ctx->SP-1]) ? fl_ctx->F : fl_ctx->T); NEXT_OP;
1324 : 202998000 : OP(OP_NOT)
1325 [ + + ]: 202998000 : fl_ctx->Stack[fl_ctx->SP-1] = ((fl_ctx->Stack[fl_ctx->SP-1]==fl_ctx->F) ? fl_ctx->T : fl_ctx->F); NEXT_OP;
1326 : 9316320 : OP(OP_NULLP)
1327 [ + + ]: 9316320 : fl_ctx->Stack[fl_ctx->SP-1] = ((fl_ctx->Stack[fl_ctx->SP-1]==fl_ctx->NIL) ? fl_ctx->T : fl_ctx->F); NEXT_OP;
1328 : 0 : OP(OP_BOOLEANP)
1329 : 0 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1330 [ # # # # ]: 0 : fl_ctx->Stack[fl_ctx->SP-1] = ((fl_apply_v == fl_ctx->T || fl_apply_v == fl_ctx->F) ? fl_ctx->T:fl_ctx->F); NEXT_OP;
1331 : 109885400 : OP(OP_SYMBOLP)
1332 [ + + ]: 109885400 : fl_ctx->Stack[fl_ctx->SP-1] = (issymbol(fl_ctx->Stack[fl_ctx->SP-1]) ? fl_ctx->T : fl_ctx->F); NEXT_OP;
1333 : 18265460 : OP(OP_NUMBERP)
1334 : 18265460 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1335 [ + + ]: 18265460 : fl_ctx->Stack[fl_ctx->SP-1] = (fl_isnumber(fl_ctx, fl_apply_v) ? fl_ctx->T:fl_ctx->F); NEXT_OP;
1336 : 0 : OP(OP_FIXNUMP)
1337 [ # # ]: 0 : fl_ctx->Stack[fl_ctx->SP-1] = (isfixnum(fl_ctx->Stack[fl_ctx->SP-1]) ? fl_ctx->T : fl_ctx->F); NEXT_OP;
1338 : 0 : OP(OP_BOUNDP)
1339 : 0 : sym = tosymbol(fl_ctx, fl_ctx->Stack[fl_ctx->SP-1], "bound?");
1340 [ # # ]: 0 : fl_ctx->Stack[fl_ctx->SP-1] = ((sym->binding == UNBOUND) ? fl_ctx->F : fl_ctx->T);
1341 : 0 : NEXT_OP;
1342 : 0 : OP(OP_BUILTINP)
1343 : 0 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1344 [ # # # # : 0 : fl_ctx->Stack[fl_ctx->SP-1] = (isbuiltin(fl_apply_v) || iscbuiltin(fl_ctx, fl_apply_v)) ? fl_ctx->T : fl_ctx->F;
# # # # ]
1345 : 0 : NEXT_OP;
1346 : 2088420 : OP(OP_FUNCTIONP)
1347 : 2088420 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1348 : 4176840 : fl_ctx->Stack[fl_ctx->SP-1] = ((tag(fl_apply_v)==TAG_FUNCTION &&
1349 [ # # # # ]: 0 : (uintval(fl_apply_v)<=OP_ASET || fl_apply_v>(N_BUILTINS<<3))) ||
1350 [ - + - + : 2088420 : iscbuiltin(fl_ctx, fl_apply_v)) ? fl_ctx->T : fl_ctx->F;
- - ]
1351 : 2088420 : NEXT_OP;
1352 : 6499300 : OP(OP_VECTORP)
1353 [ + + ]: 6499300 : fl_ctx->Stack[fl_ctx->SP-1] = (isvector(fl_ctx->Stack[fl_ctx->SP-1]) ? fl_ctx->T : fl_ctx->F); NEXT_OP;
1354 : :
1355 : 77549600 : OP(OP_CONS)
1356 : : #ifdef MEMDEBUG2
1357 : : fl_apply_c = (cons_t*)ptr(mk_cons(fl_ctx));
1358 : : #else
1359 [ + + ]: 77549600 : if (fl_ctx->curheap > fl_ctx->lim)
1360 : 298 : gc(fl_ctx, 0);
1361 : 77549600 : fl_apply_c = (cons_t*)fl_ctx->curheap;
1362 : 77549600 : fl_ctx->curheap += sizeof(cons_t);
1363 : : #endif
1364 : 77549600 : fl_apply_c->car = fl_ctx->Stack[fl_ctx->SP-2];
1365 : 77549600 : fl_apply_c->cdr = fl_ctx->Stack[fl_ctx->SP-1];
1366 : 77549600 : fl_ctx->Stack[fl_ctx->SP-2] = tagptr(fl_apply_c, TAG_CONS);
1367 : 77549600 : POPN(fl_ctx, 1); NEXT_OP;
1368 : 1064840000 : OP(OP_CAR)
1369 : 1064840000 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1370 [ - + ]: 1064840000 : if (!iscons(fl_apply_v)) type_error(fl_ctx, "car", "cons", fl_apply_v);
1371 : 1064840000 : fl_ctx->Stack[fl_ctx->SP-1] = car_(fl_apply_v);
1372 : 1064840000 : NEXT_OP;
1373 : 447386000 : OP(OP_CDR)
1374 : 447386000 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1375 [ - + ]: 447386000 : if (!iscons(fl_apply_v)) type_error(fl_ctx, "cdr", "cons", fl_apply_v);
1376 : 447386000 : fl_ctx->Stack[fl_ctx->SP-1] = cdr_(fl_apply_v);
1377 : 447386000 : NEXT_OP;
1378 : 81549200 : OP(OP_CADR)
1379 : 81549200 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1380 [ - + ]: 81549200 : if (!iscons(fl_apply_v)) type_error(fl_ctx, "cdr", "cons", fl_apply_v);
1381 : 81549200 : fl_apply_v = cdr_(fl_apply_v);
1382 [ - + ]: 81549200 : if (!iscons(fl_apply_v)) type_error(fl_ctx, "car", "cons", fl_apply_v);
1383 : 81549200 : fl_ctx->Stack[fl_ctx->SP-1] = car_(fl_apply_v);
1384 : 81549200 : NEXT_OP;
1385 : 68496400 : OP(OP_SETCAR)
1386 : 68496400 : car(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2]) = fl_ctx->Stack[fl_ctx->SP-1];
1387 : 68496400 : POPN(fl_ctx, 1); NEXT_OP;
1388 : 20665200 : OP(OP_SETCDR)
1389 : 20665200 : cdr(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2]) = fl_ctx->Stack[fl_ctx->SP-1];
1390 : 20665200 : POPN(fl_ctx, 1); NEXT_OP;
1391 : 42826400 : OP(OP_LIST)
1392 : 42826400 : n = *ip++;
1393 : 42826400 : apply_list:
1394 [ + - ]: 42826400 : if (n > 0) {
1395 : 42826400 : fl_apply_v = list(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-n], n);
1396 : 42826400 : POPN(fl_ctx, n);
1397 : 42826400 : PUSH(fl_ctx, fl_apply_v);
1398 : : }
1399 : : else {
1400 : 0 : PUSH(fl_ctx, fl_ctx->NIL);
1401 : : }
1402 : 42826400 : NEXT_OP;
1403 : :
1404 : 6303720 : OP(OP_TAPPLY)
1405 : 6303720 : n = *ip++;
1406 : 6303720 : apply_tapply:
1407 : 6303720 : fl_apply_v = POP(fl_ctx); // arglist
1408 : 6303720 : n = fl_ctx->SP-(n-2); // n-2 == # leading arguments not in the list
1409 [ + + ]: 21059600 : while (iscons(fl_apply_v)) {
1410 [ - + ]: 14755900 : if (fl_ctx->SP >= fl_ctx->N_STACK)
1411 : 0 : grow_stack(fl_ctx);
1412 : 14755900 : PUSH(fl_ctx, car_(fl_apply_v));
1413 : 14755900 : fl_apply_v = cdr_(fl_apply_v);
1414 : : }
1415 : 6303720 : n = fl_ctx->SP-n;
1416 : 6303720 : goto do_tcall;
1417 : 1116376 : OP(OP_APPLY)
1418 : 1116376 : n = *ip++;
1419 : 1116376 : apply_apply:
1420 : 1116376 : fl_apply_v = POP(fl_ctx); // arglist
1421 : 1116376 : n = fl_ctx->SP-(n-2); // n-2 == # leading arguments not in the list
1422 [ + + ]: 1911906 : while (iscons(fl_apply_v)) {
1423 [ - + ]: 795530 : if (fl_ctx->SP >= fl_ctx->N_STACK)
1424 : 0 : grow_stack(fl_ctx);
1425 : 795530 : PUSH(fl_ctx, car_(fl_apply_v));
1426 : 795530 : fl_apply_v = cdr_(fl_apply_v);
1427 : : }
1428 : 1116376 : n = fl_ctx->SP-n;
1429 : 1116376 : goto do_call;
1430 : :
1431 : 0 : OP(OP_ADD)
1432 : 0 : n = *ip++;
1433 : 0 : apply_add:
1434 : 0 : s = 0;
1435 : 0 : i = fl_ctx->SP-n;
1436 [ # # ]: 0 : for (; i < fl_ctx->SP; i++) {
1437 [ # # ]: 0 : if (isfixnum(fl_ctx->Stack[i])) {
1438 : 0 : s += numval(fl_ctx->Stack[i]);
1439 [ # # # # ]: 0 : if (!fits_fixnum(s)) {
1440 : 0 : i++;
1441 : 0 : goto add_ovf;
1442 : : }
1443 : : }
1444 : : else {
1445 : 0 : add_ovf:
1446 : 0 : fl_apply_v = fl_add_any(fl_ctx, &fl_ctx->Stack[i], fl_ctx->SP-i, s);
1447 : 0 : break;
1448 : : }
1449 : : }
1450 [ # # ]: 0 : if (i==fl_ctx->SP)
1451 : 0 : fl_apply_v = fixnum(s);
1452 : 0 : POPN(fl_ctx, n);
1453 : 0 : PUSH(fl_ctx, fl_apply_v);
1454 : 0 : NEXT_OP;
1455 : 6795020 : OP(OP_ADD2)
1456 [ + - ]: 6795020 : if (bothfixnums(fl_ctx->Stack[fl_ctx->SP-1], fl_ctx->Stack[fl_ctx->SP-2])) {
1457 : 6795020 : s = numval(fl_ctx->Stack[fl_ctx->SP-1]) + numval(fl_ctx->Stack[fl_ctx->SP-2]);
1458 [ - + - - ]: 6795020 : if (fits_fixnum(s))
1459 : 6795020 : fl_apply_v = fixnum(s);
1460 : : else
1461 : 0 : fl_apply_v = mk_ptrdiff(fl_ctx, s);
1462 : : }
1463 : : else {
1464 : 0 : fl_apply_v = fl_add_any(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-2], 2, 0);
1465 : : }
1466 : 6795020 : POPN(fl_ctx, 1);
1467 : 6795020 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1468 : 6795020 : NEXT_OP;
1469 : 0 : OP(OP_SUB)
1470 : 0 : n = *ip++;
1471 : 0 : apply_sub:
1472 [ # # ]: 0 : if (n == 2) goto do_sub2;
1473 [ # # ]: 0 : if (n == 1) goto do_neg;
1474 : 0 : i = fl_ctx->SP-n;
1475 : : // we need to pass the full arglist on to fl_add_any
1476 : : // so it can handle rest args properly
1477 : 0 : PUSH(fl_ctx, fl_ctx->Stack[i]);
1478 : 0 : fl_ctx->Stack[i] = fixnum(0);
1479 : 0 : fl_ctx->Stack[i+1] = fl_neg(fl_ctx, fl_add_any(fl_ctx, &fl_ctx->Stack[i], n, 0));
1480 : 0 : fl_ctx->Stack[i] = POP(fl_ctx);
1481 : 0 : fl_apply_v = fl_add_any(fl_ctx, &fl_ctx->Stack[i], 2, 0);
1482 : 0 : POPN(fl_ctx, n);
1483 : 0 : PUSH(fl_ctx, fl_apply_v);
1484 : 0 : NEXT_OP;
1485 : 0 : OP(OP_NEG)
1486 : 0 : do_neg:
1487 [ # # ]: 0 : if (isfixnum(fl_ctx->Stack[fl_ctx->SP-1]))
1488 : 0 : fl_ctx->Stack[fl_ctx->SP-1] = fixnum(-numval(fl_ctx->Stack[fl_ctx->SP-1]));
1489 : : else
1490 : 0 : fl_ctx->Stack[fl_ctx->SP-1] = fl_neg(fl_ctx, fl_ctx->Stack[fl_ctx->SP-1]);
1491 : 0 : NEXT_OP;
1492 : 88505200 : OP(OP_SUB2)
1493 : 88505200 : do_sub2:
1494 [ + - ]: 88505200 : if (bothfixnums(fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1])) {
1495 : 88505200 : s = numval(fl_ctx->Stack[fl_ctx->SP-2]) - numval(fl_ctx->Stack[fl_ctx->SP-1]);
1496 [ - + - - ]: 88505200 : if (fits_fixnum(s))
1497 : 88505200 : fl_apply_v = fixnum(s);
1498 : : else
1499 : 0 : fl_apply_v = mk_ptrdiff(fl_ctx, s);
1500 : : }
1501 : : else {
1502 : 0 : fl_ctx->Stack[fl_ctx->SP-1] = fl_neg(fl_ctx, fl_ctx->Stack[fl_ctx->SP-1]);
1503 : 0 : fl_apply_v = fl_add_any(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-2], 2, 0);
1504 : : }
1505 : 88505200 : POPN(fl_ctx, 1);
1506 : 88505200 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1507 : 88505200 : NEXT_OP;
1508 : 8696 : OP(OP_MUL)
1509 : 8696 : n = *ip++;
1510 : 8696 : apply_mul:
1511 : 8696 : fl_apply_accum = 1;
1512 : 8696 : i = fl_ctx->SP-n;
1513 [ + + ]: 26088 : for (; i < fl_ctx->SP; i++) {
1514 [ + - ]: 17392 : if (isfixnum(fl_ctx->Stack[i])) {
1515 : 17392 : fl_apply_accum *= numval(fl_ctx->Stack[i]);
1516 : : }
1517 : : else {
1518 : 0 : fl_apply_v = fl_mul_any(fl_ctx, &fl_ctx->Stack[i], fl_ctx->SP-i, fl_apply_accum);
1519 : 0 : break;
1520 : : }
1521 : : }
1522 [ + - ]: 8696 : if (i == fl_ctx->SP) {
1523 [ - + - - ]: 8696 : if (fits_fixnum(fl_apply_accum))
1524 : 8696 : fl_apply_v = fixnum(fl_apply_accum);
1525 : : else
1526 : 0 : fl_apply_v = return_from_int64(fl_ctx, fl_apply_accum);
1527 : : }
1528 : 8696 : POPN(fl_ctx, n);
1529 : 8696 : PUSH(fl_ctx, fl_apply_v);
1530 : 8696 : NEXT_OP;
1531 : 12 : OP(OP_DIV)
1532 : 12 : n = *ip++;
1533 : 12 : apply_div:
1534 : 12 : i = fl_ctx->SP-n;
1535 [ - + ]: 12 : if (n == 1) {
1536 : 0 : fl_ctx->Stack[fl_ctx->SP-1] = fl_div2(fl_ctx, fixnum(1), fl_ctx->Stack[i]);
1537 : : }
1538 : : else {
1539 [ - + ]: 12 : if (n > 2) {
1540 : 0 : PUSH(fl_ctx, fl_ctx->Stack[i]);
1541 : 0 : fl_ctx->Stack[i] = fixnum(1);
1542 : 0 : fl_ctx->Stack[i+1] = fl_mul_any(fl_ctx, &fl_ctx->Stack[i], n, 1);
1543 : 0 : fl_ctx->Stack[i] = POP(fl_ctx);
1544 : : }
1545 : 12 : fl_apply_v = fl_div2(fl_ctx, fl_ctx->Stack[i], fl_ctx->Stack[i+1]);
1546 : 12 : POPN(fl_ctx, n);
1547 : 12 : PUSH(fl_ctx, fl_apply_v);
1548 : : }
1549 : 12 : NEXT_OP;
1550 : 132 : OP(OP_IDIV)
1551 : 132 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-2]; fl_apply_e = fl_ctx->Stack[fl_ctx->SP-1];
1552 [ + - ]: 132 : if (bothfixnums(fl_apply_v, fl_apply_e)) {
1553 [ - + ]: 132 : if (fl_apply_e==0) DivideByZeroError(fl_ctx);
1554 : 132 : fl_apply_v = fixnum(numval(fl_apply_v) / numval(fl_apply_e));
1555 : : }
1556 : : else
1557 : 0 : fl_apply_v = fl_idiv2(fl_ctx, fl_apply_v, fl_apply_e);
1558 : 132 : POPN(fl_ctx, 1);
1559 : 132 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1560 : 132 : NEXT_OP;
1561 : 154644600 : OP(OP_NUMEQ)
1562 : 154644600 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-2]; fl_apply_e = fl_ctx->Stack[fl_ctx->SP-1];
1563 [ + + ]: 154644600 : if (bothfixnums(fl_apply_v, fl_apply_e))
1564 [ + + ]: 154348800 : fl_apply_v = (fl_apply_v == fl_apply_e) ? fl_ctx->T : fl_ctx->F;
1565 : : else
1566 [ + + ]: 295960 : fl_apply_v = (!numeric_compare(fl_ctx,fl_apply_v,fl_apply_e,1,0,"=")) ? fl_ctx->T : fl_ctx->F;
1567 : 154644600 : POPN(fl_ctx, 1);
1568 : 154644600 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1569 : 154644600 : NEXT_OP;
1570 : 142689800 : OP(OP_LT)
1571 [ + + ]: 142689800 : if (bothfixnums(fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1])) {
1572 [ + + ]: 142159400 : fl_apply_v = (numval(fl_ctx->Stack[fl_ctx->SP-2]) < numval(fl_ctx->Stack[fl_ctx->SP-1])) ? fl_ctx->T : fl_ctx->F;
1573 : : }
1574 : : else {
1575 : 1060772 : fl_apply_v = (numval(fl_compare(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1])) < 0) ?
1576 [ + + ]: 530386 : fl_ctx->T : fl_ctx->F;
1577 : : }
1578 : 142689800 : POPN(fl_ctx, 1);
1579 : 142689800 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1580 : 142689800 : NEXT_OP;
1581 : 0 : OP(OP_COMPARE)
1582 : 0 : fl_ctx->Stack[fl_ctx->SP-2] = compare_(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], fl_ctx->Stack[fl_ctx->SP-1], 0);
1583 : 0 : POPN(fl_ctx, 1);
1584 : 0 : NEXT_OP;
1585 : :
1586 : 1003586 : OP(OP_VECTOR)
1587 : 1003586 : n = *ip++;
1588 : 1003586 : apply_vector:
1589 : 1003586 : fl_apply_v = alloc_vector(fl_ctx, n, 0);
1590 [ + - ]: 1003586 : if (n) {
1591 : 1003586 : memcpy(&vector_elt(fl_apply_v,0), &fl_ctx->Stack[fl_ctx->SP-n], n*sizeof(value_t));
1592 : 1003586 : POPN(fl_ctx, n);
1593 : : }
1594 : 1003586 : PUSH(fl_ctx, fl_apply_v);
1595 : 1003586 : NEXT_OP;
1596 : :
1597 : 154735000 : OP(OP_AREF)
1598 : 154735000 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-2];
1599 [ + - ]: 154735000 : if (isvector(fl_apply_v)) {
1600 : 154735000 : fl_apply_e = fl_ctx->Stack[fl_ctx->SP-1];
1601 [ + - ]: 154735000 : if (isfixnum(fl_apply_e))
1602 : 154735000 : i = numval(fl_apply_e);
1603 : : else
1604 : 0 : i = (uint32_t)tosize(fl_ctx, fl_apply_e, "aref");
1605 [ - + ]: 154735000 : if ((unsigned)i >= vector_size(fl_apply_v))
1606 : 0 : bounds_error(fl_ctx, "aref", fl_apply_v, fl_apply_e);
1607 : 154735000 : fl_apply_v = vector_elt(fl_apply_v, i);
1608 : : }
1609 [ # # ]: 0 : else if (isarray(fl_apply_v)) {
1610 : 0 : fl_apply_v = cvalue_array_aref(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-2]);
1611 : : }
1612 : : else {
1613 : 0 : type_error(fl_ctx, "aref", "sequence", fl_apply_v);
1614 : : }
1615 : 154735000 : POPN(fl_ctx, 1);
1616 : 154735000 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1617 : 154735000 : NEXT_OP;
1618 : 28280400 : OP(OP_ASET)
1619 : 28280400 : fl_apply_e = fl_ctx->Stack[fl_ctx->SP-3];
1620 [ + - ]: 28280400 : if (isvector(fl_apply_e)) {
1621 : 28280400 : i = tofixnum(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], "aset!");
1622 [ - + ]: 28280400 : if ((unsigned)i >= vector_size(fl_apply_e))
1623 : 0 : bounds_error(fl_ctx, "aset!", fl_apply_v, fl_ctx->Stack[fl_ctx->SP-1]);
1624 : 28280400 : vector_elt(fl_apply_e, i) = (fl_apply_v=fl_ctx->Stack[fl_ctx->SP-1]);
1625 : : }
1626 [ # # ]: 0 : else if (isarray(fl_apply_e)) {
1627 : 0 : fl_apply_v = cvalue_array_aset(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-3]);
1628 : : }
1629 : : else {
1630 : 0 : type_error(fl_ctx, "aset!", "sequence", fl_apply_e);
1631 : : }
1632 : 28280400 : POPN(fl_ctx, 2);
1633 : 28280400 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1634 : 28280400 : NEXT_OP;
1635 : 7280 : OP(OP_FOR)
1636 : 7280 : s = tofixnum(fl_ctx, fl_ctx->Stack[fl_ctx->SP-3], "for");
1637 : 7280 : hi = tofixnum(fl_ctx, fl_ctx->Stack[fl_ctx->SP-2], "for");
1638 : : //f = fl_ctx->Stack[fl_ctx->SP-1];
1639 : 7280 : fl_apply_v = FL_UNSPECIFIED(fl_ctx);
1640 : 7280 : fl_ctx->SP += 2;
1641 : 7280 : n = fl_ctx->SP;
1642 [ + + ]: 14994 : for(; s <= hi; s++) {
1643 : 7714 : fl_ctx->Stack[fl_ctx->SP-2] = fl_ctx->Stack[fl_ctx->SP-3];
1644 : 7714 : fl_ctx->Stack[fl_ctx->SP-1] = fixnum(s);
1645 : 7714 : fl_apply_v = apply_cl(fl_ctx, 1);
1646 : 7714 : fl_ctx->SP = n;
1647 : : }
1648 : 7280 : POPN(fl_ctx, 4);
1649 : 7280 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1650 : 7280 : NEXT_OP;
1651 : :
1652 : 148913800 : OP(OP_LOADT) PUSH(fl_ctx, fl_ctx->T); NEXT_OP;
1653 : 134759800 : OP(OP_LOADF) PUSH(fl_ctx, fl_ctx->F); NEXT_OP;
1654 : 102109400 : OP(OP_LOADNIL) PUSH(fl_ctx, fl_ctx->NIL); NEXT_OP;
1655 : 372062000 : OP(OP_LOAD0) PUSH(fl_ctx, fixnum(0)); NEXT_OP;
1656 : 119793200 : OP(OP_LOAD1) PUSH(fl_ctx, fixnum(1)); NEXT_OP;
1657 : 159369000 : OP(OP_LOADI8) s = (int8_t)*ip++; PUSH(fl_ctx, fixnum(s)); NEXT_OP;
1658 : 1784304000 : OP(OP_LOADV)
1659 : 1784304000 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1660 [ - + ]: 1784304000 : assert(*ip < vector_size(fl_apply_v));
1661 : 1784304000 : fl_apply_v = vector_elt(fl_apply_v, *ip); ip++;
1662 : 1784304000 : PUSH(fl_ctx, fl_apply_v);
1663 : 1784304000 : NEXT_OP;
1664 : 0 : OP(OP_LOADVL)
1665 : 0 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1666 : 0 : fl_apply_v = vector_elt(fl_apply_v, GET_INT32(ip)); ip+=4;
1667 : 0 : PUSH(fl_ctx, fl_apply_v);
1668 : 0 : NEXT_OP;
1669 : 0 : OP(OP_LOADGL)
1670 : 0 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1671 : 0 : fl_apply_v = vector_elt(fl_apply_v, GET_INT32(ip)); ip+=4;
1672 : 0 : goto do_loadg;
1673 : 1149760000 : OP(OP_LOADG)
1674 : 1149760000 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1675 [ - + ]: 1149760000 : assert(*ip < vector_size(fl_apply_v));
1676 : 1149760000 : fl_apply_v = vector_elt(fl_apply_v, *ip); ip++;
1677 : 1149760000 : do_loadg:
1678 [ - + ]: 1149760000 : assert(issymbol(fl_apply_v));
1679 : 1149760000 : sym = (symbol_t*)ptr(fl_apply_v);
1680 [ - + ]: 1149760000 : if (sym->binding == UNBOUND)
1681 : 0 : fl_raise(fl_ctx, fl_list2(fl_ctx, fl_ctx->UnboundError, fl_apply_v));
1682 : 1149760000 : PUSH(fl_ctx, sym->binding);
1683 : 1149760000 : NEXT_OP;
1684 : :
1685 : 0 : OP(OP_SETGL)
1686 : 0 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1687 : 0 : fl_apply_v = vector_elt(fl_apply_v, GET_INT32(ip)); ip+=4;
1688 : 0 : goto do_setg;
1689 : 15067860 : OP(OP_SETG)
1690 : 15067860 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1691 [ - + ]: 15067860 : assert(*ip < vector_size(fl_apply_v));
1692 : 15067860 : fl_apply_v = vector_elt(fl_apply_v, *ip); ip++;
1693 : 15067860 : do_setg:
1694 [ - + ]: 15067860 : assert(issymbol(fl_apply_v));
1695 : 15067860 : sym = (symbol_t*)ptr(fl_apply_v);
1696 : 15067860 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1697 [ + - ]: 15067860 : if (!isconstant(sym))
1698 : 15067860 : sym->binding = fl_apply_v;
1699 : 15067860 : NEXT_OP;
1700 : :
1701 : 1136954000 : OP(OP_LOADA)
1702 : 1136954000 : i = *ip++;
1703 : 1136954000 : fl_apply_v = fl_ctx->Stack[bp+i];
1704 : 1136954000 : PUSH(fl_ctx, fl_apply_v);
1705 : 1136954000 : NEXT_OP;
1706 : 3135620000 : OP(OP_LOADA0)
1707 : 3135620000 : fl_apply_v = fl_ctx->Stack[bp];
1708 : 3135620000 : PUSH(fl_ctx, fl_apply_v);
1709 : 3135620000 : NEXT_OP;
1710 : 1338662000 : OP(OP_LOADA1)
1711 : 1338662000 : fl_apply_v = fl_ctx->Stack[bp+1];
1712 : 1338662000 : PUSH(fl_ctx, fl_apply_v);
1713 : 1338662000 : NEXT_OP;
1714 : 0 : OP(OP_LOADAL)
1715 : 0 : i = GET_INT32(ip); ip+=4;
1716 : 0 : fl_apply_v = fl_ctx->Stack[bp+i];
1717 : 0 : PUSH(fl_ctx, fl_apply_v);
1718 : 0 : NEXT_OP;
1719 : 65800000 : OP(OP_SETA)
1720 : 65800000 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1721 : 65800000 : i = *ip++;
1722 : 65800000 : fl_ctx->Stack[bp+i] = fl_apply_v;
1723 : 65800000 : NEXT_OP;
1724 : 0 : OP(OP_SETAL)
1725 : 0 : fl_apply_v = fl_ctx->Stack[fl_ctx->SP-1];
1726 : 0 : i = GET_INT32(ip); ip+=4;
1727 : 0 : fl_ctx->Stack[bp+i] = fl_apply_v;
1728 : 0 : NEXT_OP;
1729 : :
1730 : 62410000 : OP(OP_BOX)
1731 : 62410000 : i = *ip++;
1732 : 62410000 : fl_apply_v = mk_cons(fl_ctx);
1733 : 62410000 : car_(fl_apply_v) = fl_ctx->Stack[bp+i];
1734 : 62410000 : cdr_(fl_apply_v) = fl_ctx->NIL;
1735 : 62410000 : fl_ctx->Stack[bp+i] = fl_apply_v;
1736 : 62410000 : NEXT_OP;
1737 : 0 : OP(OP_BOXL)
1738 : 0 : i = GET_INT32(ip); ip+=4;
1739 : 0 : fl_apply_v = mk_cons(fl_ctx);
1740 : 0 : car_(fl_apply_v) = fl_ctx->Stack[bp+i];
1741 : 0 : cdr_(fl_apply_v) = fl_ctx->NIL;
1742 : 0 : fl_ctx->Stack[bp+i] = fl_apply_v;
1743 : 0 : NEXT_OP;
1744 : :
1745 : 43696600 : OP(OP_SHIFT)
1746 : 43696600 : i = *ip++;
1747 : 43696600 : fl_ctx->Stack[fl_ctx->SP-1-i] = fl_ctx->Stack[fl_ctx->SP-1];
1748 : 43696600 : fl_ctx->SP -= i;
1749 : 43696600 : NEXT_OP;
1750 : :
1751 : 218970000 : OP(OP_LOADC)
1752 : 218970000 : i = *ip++;
1753 : 218970000 : fl_apply_v = fl_ctx->Stack[bp+nargs];
1754 [ - + ]: 218970000 : assert(isvector(fl_apply_v));
1755 [ - + ]: 218970000 : assert(i < vector_size(fl_apply_v));
1756 : 218970000 : PUSH(fl_ctx, vector_elt(fl_apply_v, i));
1757 : 218970000 : NEXT_OP;
1758 : :
1759 : 358452000 : OP(OP_LOADC0)
1760 : 358452000 : PUSH(fl_ctx, vector_elt(fl_ctx->Stack[bp+nargs], 0));
1761 : 358452000 : NEXT_OP;
1762 : 142861800 : OP(OP_LOADC1)
1763 : 142861800 : PUSH(fl_ctx, vector_elt(fl_ctx->Stack[bp+nargs], 1));
1764 : 142861800 : NEXT_OP;
1765 : :
1766 : 0 : OP(OP_LOADCL)
1767 : 0 : i = GET_INT32(ip); ip+=4;
1768 : 0 : fl_apply_v = fl_ctx->Stack[bp+nargs];
1769 : 0 : PUSH(fl_ctx, vector_elt(fl_apply_v, i));
1770 : 0 : NEXT_OP;
1771 : :
1772 : 129912400 : OP(OP_CLOSURE)
1773 : 129912400 : n = *ip++;
1774 [ - + ]: 129912400 : assert(n > 0);
1775 : 129912400 : fl_apply_pv = alloc_words(fl_ctx, n + 1);
1776 : 129912400 : fl_apply_v = tagptr(fl_apply_pv, TAG_VECTOR);
1777 : 129912400 : fl_apply_pv[0] = fixnum(n);
1778 : 129912400 : i = 1;
1779 : : do {
1780 : 294870000 : fl_apply_pv[i] = fl_ctx->Stack[fl_ctx->SP-n + i-1];
1781 : 294870000 : i++;
1782 [ + + ]: 294870000 : } while (i<=n);
1783 : 129912400 : POPN(fl_ctx, n);
1784 : 129912400 : PUSH(fl_ctx, fl_apply_v);
1785 : : #ifdef MEMDEBUG2
1786 : : fl_apply_pv = alloc_words(fl_ctx, 4);
1787 : : #else
1788 [ + + ]: 129912400 : if ((value_t*)fl_ctx->curheap > ((value_t*)fl_ctx->lim)-2)
1789 : 1014 : gc(fl_ctx, 0);
1790 : 129912400 : fl_apply_pv = (value_t*)fl_ctx->curheap;
1791 : 129912400 : fl_ctx->curheap += (4*sizeof(value_t));
1792 : : #endif
1793 : 129912400 : fl_apply_e = fl_ctx->Stack[fl_ctx->SP-2]; // closure to copy
1794 [ + - + - ]: 129912400 : assert(isfunction(fl_apply_e));
1795 : 129912400 : fl_apply_pv[0] = ((value_t*)ptr(fl_apply_e))[0];
1796 : 129912400 : fl_apply_pv[1] = ((value_t*)ptr(fl_apply_e))[1];
1797 : 129912400 : fl_apply_pv[2] = fl_ctx->Stack[fl_ctx->SP-1]; // env
1798 : 129912400 : fl_apply_pv[3] = ((value_t*)ptr(fl_apply_e))[3];
1799 : 129912400 : POPN(fl_ctx, 1);
1800 : 129912400 : fl_ctx->Stack[fl_ctx->SP-1] = tagptr(fl_apply_pv, TAG_FUNCTION);
1801 : 129912400 : NEXT_OP;
1802 : :
1803 : 2718140 : OP(OP_TRYCATCH)
1804 : 2718140 : fl_apply_v = do_trycatch(fl_ctx);
1805 : 2718120 : POPN(fl_ctx, 1);
1806 : 2718120 : fl_ctx->Stack[fl_ctx->SP-1] = fl_apply_v;
1807 : 2718120 : NEXT_OP;
1808 : :
1809 : 124778800 : OP(OP_OPTARGS)
1810 : 124778800 : i = GET_INT32(ip); ip+=4;
1811 : 124778800 : n = GET_INT32(ip); ip+=4;
1812 [ - + ]: 124778800 : if (nargs < i)
1813 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too few arguments");
1814 [ + - ]: 124778800 : if ((int32_t)n > 0) {
1815 [ - + ]: 124778800 : if (nargs > n)
1816 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "apply: too many arguments");
1817 : : }
1818 : 0 : else n = -n;
1819 [ + + ]: 124778800 : if (n > nargs) {
1820 : 15629700 : n -= nargs;
1821 : 15629700 : fl_ctx->SP += n;
1822 : 15629700 : fl_ctx->Stack[fl_ctx->SP-1] = fl_ctx->Stack[fl_ctx->SP-n-1];
1823 : 15629700 : fl_ctx->Stack[fl_ctx->SP-2] = nargs+n;
1824 : 15629700 : fl_ctx->Stack[fl_ctx->SP-3] = fl_ctx->Stack[fl_ctx->SP-n-3];
1825 : 15629700 : fl_ctx->Stack[fl_ctx->SP-4] = fl_ctx->Stack[fl_ctx->SP-n-4];
1826 : 15629700 : fl_ctx->curr_frame = fl_ctx->SP;
1827 [ + + ]: 32569000 : for(i=0; i < n; i++) {
1828 : 16939320 : fl_ctx->Stack[bp+nargs+i] = UNBOUND;
1829 : : }
1830 : 15629700 : nargs += n;
1831 : : }
1832 : 124778800 : NEXT_OP;
1833 : 0 : OP(OP_KEYARGS)
1834 : 0 : fl_apply_v = fn_vals(fl_ctx->Stack[bp-1]);
1835 : 0 : fl_apply_v = vector_elt(fl_apply_v, 0);
1836 : 0 : i = GET_INT32(ip); ip+=4;
1837 : 0 : n = GET_INT32(ip); ip+=4;
1838 : 0 : s = GET_INT32(ip); ip+=4;
1839 : 0 : nargs = process_keys(fl_ctx, fl_apply_v, i, n, llabs(s)-(i+n), bp, nargs, s<0);
1840 : 0 : NEXT_OP;
1841 : :
1842 : : #ifndef USE_COMPUTED_GOTO
1843 : : default:
1844 : : goto dispatch;
1845 : : #endif
1846 : : }
1847 : : }
1848 : : #ifdef USE_COMPUTED_GOTO
1849 : : return UNBOUND; // not reached
1850 : : #else
1851 : : goto dispatch;
1852 : : #endif
1853 : : }
1854 : :
1855 : 50010 : static uint32_t compute_maxstack(uint8_t *code, size_t len, int bswap)
1856 : : {
1857 : 50010 : uint8_t *ip = code+4, *end = code+len;
1858 : : uint8_t op;
1859 : 50010 : uint32_t i, n, sp = 0, maxsp = 0;
1860 : :
1861 : : while (1) {
1862 [ + + ]: 1745370 : if ((int32_t)sp > (int32_t)maxsp) maxsp = sp;
1863 [ + + ]: 1745370 : if (ip >= end) break;
1864 : 1695360 : op = *ip++;
1865 [ + + - - : 1695360 : switch (op) {
+ - + + -
+ - + - +
- + - + +
+ + + + +
+ + + + -
+ - + -
+ ]
1866 : 47370 : case OP_ARGC:
1867 : 47370 : n = *ip++;
1868 : 47370 : break;
1869 : 1290 : case OP_VARGC:
1870 : 1290 : n = *ip++;
1871 : 1290 : sp += (n+2);
1872 : 1290 : break;
1873 : 0 : case OP_LARGC:
1874 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1875 : 0 : n = GET_INT32(ip); ip+=4;
1876 : 0 : break;
1877 : 0 : case OP_LVARGC:
1878 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1879 : 0 : n = GET_INT32(ip); ip+=4;
1880 : 0 : sp += (n+2);
1881 : 0 : break;
1882 : 1350 : case OP_OPTARGS:
1883 [ - + ]: 1350 : if (bswap) SWAP_INT32(ip);
1884 : 1350 : i = GET_INT32(ip); ip+=4;
1885 [ - + ]: 1350 : if (bswap) SWAP_INT32(ip);
1886 : 1350 : n = abs(GET_INT32(ip)); ip+=4;
1887 : 1350 : sp += (n-i);
1888 : 1350 : break;
1889 : 0 : case OP_KEYARGS:
1890 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1891 : 0 : i = GET_INT32(ip); ip+=4;
1892 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1893 : 0 : n = GET_INT32(ip); ip+=4;
1894 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1895 : 0 : n = abs(GET_INT32(ip)); ip+=4;
1896 : 0 : sp += (n-i);
1897 : 0 : break;
1898 : 1860 : case OP_BRBOUND:
1899 [ - + ]: 1860 : if (bswap) SWAP_INT32(ip);
1900 : 1860 : ip+=4;
1901 : 1860 : sp++;
1902 : 1860 : break;
1903 : :
1904 : 217650 : case OP_TCALL: case OP_CALL:
1905 : 217650 : n = *ip++; // nargs
1906 : 217650 : sp -= n;
1907 : 217650 : break;
1908 : 0 : case OP_TCALLL: case OP_CALLL:
1909 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1910 : 0 : n = GET_INT32(ip); ip+=4;
1911 : 0 : sp -= n;
1912 : 0 : break;
1913 : 21900 : case OP_JMP:
1914 [ - + ]: 21900 : if (bswap) SWAP_INT16(ip);
1915 : 21900 : ip += 2; break;
1916 : 0 : case OP_JMPL:
1917 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1918 : 0 : ip += 4; break;
1919 : 89430 : case OP_BRF: case OP_BRT:
1920 [ - + ]: 89430 : if (bswap) SWAP_INT16(ip);
1921 : 89430 : ip+=2;
1922 : 89430 : sp--;
1923 : 89430 : break;
1924 : 0 : case OP_BRFL: case OP_BRTL:
1925 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1926 : 0 : ip += 4;
1927 : 0 : sp--;
1928 : 0 : break;
1929 : 7650 : case OP_BRNE:
1930 [ - + ]: 7650 : if (bswap) SWAP_INT16(ip);
1931 : 7650 : ip += 2;
1932 : 7650 : sp -= 2;
1933 : 7650 : break;
1934 : 0 : case OP_BRNEL:
1935 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1936 : 0 : ip += 4;
1937 : 0 : sp -= 2;
1938 : 0 : break;
1939 : 4380 : case OP_BRNN: case OP_BRN:
1940 [ - + ]: 4380 : if (bswap) SWAP_INT16(ip);
1941 : 4380 : ip += 2;
1942 : 4380 : sp--;
1943 : 4380 : break;
1944 : 0 : case OP_BRNNL: case OP_BRNL:
1945 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
1946 : 0 : ip += 4;
1947 : 0 : sp--;
1948 : 0 : break;
1949 : 92040 : case OP_RET: sp--; break;
1950 : :
1951 : 126240 : case OP_CONS: case OP_SETCAR: case OP_SETCDR: case OP_POP:
1952 : : case OP_EQ: case OP_EQV: case OP_EQUAL: case OP_ADD2: case OP_SUB2:
1953 : : case OP_IDIV: case OP_NUMEQ: case OP_LT: case OP_COMPARE:
1954 : : case OP_AREF: case OP_TRYCATCH:
1955 : 126240 : sp--;
1956 : 126240 : break;
1957 : :
1958 : 97740 : case OP_PAIRP: case OP_ATOMP: case OP_NOT: case OP_NULLP:
1959 : : case OP_BOOLEANP: case OP_SYMBOLP: case OP_NUMBERP: case OP_FIXNUMP:
1960 : : case OP_BOUNDP: case OP_BUILTINP: case OP_FUNCTIONP: case OP_VECTORP:
1961 : : case OP_NOP: case OP_CAR: case OP_CDR: case OP_NEG:
1962 : 97740 : break;
1963 : :
1964 : 1500 : case OP_TAPPLY: case OP_APPLY:
1965 : 1500 : n = *ip++;
1966 : 1500 : sp -= (n-1);
1967 : 1500 : break;
1968 : :
1969 : 62790 : case OP_LIST: case OP_ADD: case OP_SUB: case OP_MUL: case OP_DIV:
1970 : : case OP_VECTOR:
1971 : 62790 : n = *ip++;
1972 : 62790 : sp -= (n-1);
1973 : 62790 : break;
1974 : 15180 : case OP_CLOSURE:
1975 : 15180 : n = *ip++;
1976 : 15180 : sp -= n;
1977 : 15180 : break;
1978 : 7500 : case OP_SHIFT:
1979 : 7500 : n = *ip++;
1980 : 7500 : sp -= n;
1981 : 7500 : break;
1982 : :
1983 : 660 : case OP_ASET:
1984 : 660 : sp -= 2;
1985 : 660 : break;
1986 : 90 : case OP_FOR:
1987 [ - + ]: 90 : if (sp+2 > maxsp) maxsp = sp+2;
1988 : 90 : sp -=2;
1989 : 90 : break;
1990 : :
1991 : 312450 : case OP_LOADT: case OP_LOADF: case OP_LOADNIL: case OP_LOAD0:
1992 : : case OP_LOAD1: case OP_LOADA0: case OP_LOADA1: case OP_DUP:
1993 : : case OP_LOADC0: case OP_LOADC1:
1994 : 312450 : sp++;
1995 : 312450 : break;
1996 : :
1997 : 530760 : case OP_LOADI8: case OP_LOADV: case OP_LOADG: case OP_LOADA:
1998 : 530760 : ip++;
1999 : 530760 : sp++;
2000 : 530760 : break;
2001 : 0 : case OP_LOADVL: case OP_LOADGL: case OP_LOADAL:
2002 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
2003 : 0 : ip+=4;
2004 : 0 : sp++;
2005 : 0 : break;
2006 : :
2007 : 15360 : case OP_SETG: case OP_SETA: case OP_BOX:
2008 : 15360 : ip++;
2009 : 15360 : break;
2010 : 0 : case OP_SETGL: case OP_SETAL: case OP_BOXL:
2011 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
2012 : 0 : ip+=4;
2013 : 0 : break;
2014 : :
2015 : 21090 : case OP_LOADC: ip+=1; sp++; break;
2016 : 0 : case OP_LOADCL:
2017 [ # # ]: 0 : if (bswap) SWAP_INT32(ip);
2018 : 0 : ip+=4;
2019 : 0 : sp++; break;
2020 : : }
2021 : 1695360 : }
2022 : 50010 : return maxsp+4;
2023 : : }
2024 : :
2025 : : // top = top frame pointer to start at
2026 : 0 : static value_t _stacktrace(fl_context_t *fl_ctx, uint32_t top)
2027 : : {
2028 : : uint32_t bp, sz;
2029 : 0 : value_t v, lst = fl_ctx->NIL;
2030 : 0 : fl_gc_handle(fl_ctx, &lst);
2031 [ # # ]: 0 : while (top > 0) {
2032 : 0 : sz = fl_ctx->Stack[top-2]+1;
2033 : 0 : bp = top-4-sz;
2034 : 0 : v = alloc_vector(fl_ctx, sz, 0);
2035 : 0 : memcpy(&vector_elt(v,0), &fl_ctx->Stack[bp], sz*sizeof(value_t));
2036 : 0 : lst = fl_cons(fl_ctx, v, lst);
2037 : 0 : top = fl_ctx->Stack[top-3];
2038 : : }
2039 : 0 : fl_free_gc_handles(fl_ctx, 1);
2040 : 0 : return lst;
2041 : : }
2042 : :
2043 : : // builtins -------------------------------------------------------------------
2044 : :
2045 : 240 : void assign_global_builtins(fl_context_t *fl_ctx, const builtinspec_t *b)
2046 : : {
2047 [ + + ]: 3450 : while (b->name != NULL) {
2048 : 3210 : setc(symbol(fl_ctx, b->name), cbuiltin(fl_ctx, b->name, b->fptr));
2049 : 3210 : b++;
2050 : : }
2051 : 240 : }
2052 : :
2053 : 87510 : static value_t fl_function(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2054 : : {
2055 [ + + + - ]: 87510 : if (nargs == 1 && issymbol(args[0]))
2056 : 37500 : return fl_builtin(fl_ctx, args, nargs);
2057 [ + - - + ]: 50010 : if (nargs < 2 || nargs > 4)
2058 : 0 : argcount(fl_ctx, "function", nargs, 2);
2059 [ - + ]: 50010 : if (!fl_isstring(fl_ctx, args[0]))
2060 : 0 : type_error(fl_ctx, "function", "string", args[0]);
2061 [ - + ]: 50010 : if (!isvector(args[1]))
2062 : 0 : type_error(fl_ctx, "function", "vector", args[1]);
2063 : 50010 : cvalue_t *arr = (cvalue_t*)ptr(args[0]);
2064 : 50010 : cv_pin(fl_ctx, arr);
2065 : 50010 : char *data = (char*)cv_data(arr);
2066 : 50010 : int swap = 0;
2067 [ + + ]: 50010 : if ((uint8_t)data[4] >= N_OPCODES) {
2068 : : // read syntax, shifted 48 for compact text representation
2069 : 49050 : size_t i, sz = cv_len(arr);
2070 [ + + ]: 3116700 : for(i=0; i < sz; i++)
2071 : 3067640 : data[i] -= 48;
2072 : : }
2073 : : else {
2074 : : #if BYTE_ORDER == BIG_ENDIAN
2075 : : swap = 1;
2076 : : #endif
2077 : : }
2078 : 50010 : uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), swap);
2079 : 50010 : PUT_INT32(data, ms);
2080 : 50010 : function_t *fn = (function_t*)alloc_words(fl_ctx, 4);
2081 : 50010 : value_t fv = tagptr(fn, TAG_FUNCTION);
2082 : 50010 : fn->bcode = args[0];
2083 : 50010 : fn->vals = args[1];
2084 : 50010 : fn->env = fl_ctx->NIL;
2085 : 50010 : fn->name = fl_ctx->LAMBDA;
2086 [ + + ]: 50010 : if (nargs > 2) {
2087 [ + + ]: 26850 : if (issymbol(args[2])) {
2088 : 25560 : fn->name = args[2];
2089 [ - + ]: 25560 : if (nargs > 3)
2090 : 0 : fn->env = args[3];
2091 : : }
2092 : : else {
2093 : 1290 : fn->env = args[2];
2094 [ - + ]: 1290 : if (nargs > 3) {
2095 [ # # ]: 0 : if (!issymbol(args[3]))
2096 : 0 : type_error(fl_ctx, "function", "symbol", args[3]);
2097 : 0 : fn->name = args[3];
2098 : : }
2099 : : }
2100 [ + - - + : 26850 : if (isgensym(fl_ctx, fn->name))
- - ]
2101 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "function: name should not be a gensym");
2102 : : }
2103 : 50010 : return fv;
2104 : : }
2105 : :
2106 : 0 : static value_t fl_function_code(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2107 : : {
2108 : 0 : argcount(fl_ctx, "function:code", nargs, 1);
2109 : 0 : value_t v = args[0];
2110 [ # # # # ]: 0 : if (!isclosure(v)) type_error(fl_ctx, "function:code", "function", v);
2111 : 0 : return fn_bcode(v);
2112 : : }
2113 : 0 : static value_t fl_function_vals(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2114 : : {
2115 : 0 : argcount(fl_ctx, "function:vals", nargs, 1);
2116 : 0 : value_t v = args[0];
2117 [ # # # # ]: 0 : if (!isclosure(v)) type_error(fl_ctx, "function:vals", "function", v);
2118 : 0 : return fn_vals(v);
2119 : : }
2120 : 0 : static value_t fl_function_env(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2121 : : {
2122 : 0 : argcount(fl_ctx, "function:env", nargs, 1);
2123 : 0 : value_t v = args[0];
2124 [ # # # # ]: 0 : if (!isclosure(v)) type_error(fl_ctx, "function:env", "function", v);
2125 : 0 : return fn_env(v);
2126 : : }
2127 : 0 : static value_t fl_function_name(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2128 : : {
2129 : 0 : argcount(fl_ctx, "function:name", nargs, 1);
2130 : 0 : value_t v = args[0];
2131 [ # # # # ]: 0 : if (!isclosure(v)) type_error(fl_ctx, "function:name", "function", v);
2132 : 0 : return fn_name(v);
2133 : : }
2134 : :
2135 : 4864840 : value_t fl_copylist(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2136 : : {
2137 : 4864840 : argcount(fl_ctx, "copy-list", nargs, 1);
2138 : 4864840 : return copy_list(fl_ctx, args[0]);
2139 : : }
2140 : :
2141 : 5001980 : value_t fl_append(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2142 : : {
2143 [ + + ]: 5001980 : if (nargs == 0)
2144 : 467954 : return fl_ctx->NIL;
2145 : 4534020 : value_t first=fl_ctx->NIL, lst, lastcons=fl_ctx->NIL;
2146 : 4534020 : fl_gc_handle(fl_ctx, &first);
2147 : 4534020 : fl_gc_handle(fl_ctx, &lastcons);
2148 : 4534020 : uint32_t i=0;
2149 : : while (1) {
2150 : 9391380 : lst = args[i++];
2151 [ + + ]: 9391380 : if (i >= nargs) break;
2152 [ + + ]: 4857360 : if (iscons(lst)) {
2153 : 859424 : lst = copy_list(fl_ctx, lst);
2154 [ + + ]: 859424 : if (first == fl_ctx->NIL)
2155 : 822704 : first = lst;
2156 : : else
2157 : 36720 : cdr_(lastcons) = lst;
2158 : : #ifdef MEMDEBUG2
2159 : : lastcons = lst;
2160 : : while (cdr_(lastcons) != fl_ctx->NIL)
2161 : : lastcons = cdr_(lastcons);
2162 : : #else
2163 : 859424 : lastcons = tagptr((((cons_t*)fl_ctx->curheap)-1), TAG_CONS);
2164 : : #endif
2165 : : }
2166 [ - + ]: 3997940 : else if (lst != fl_ctx->NIL) {
2167 : 0 : type_error(fl_ctx, "append", "cons", lst);
2168 : : }
2169 : : }
2170 [ + + ]: 4534020 : if (first == fl_ctx->NIL)
2171 : 3711320 : first = lst;
2172 : : else
2173 : 822704 : cdr_(lastcons) = lst;
2174 : 4534020 : fl_free_gc_handles(fl_ctx, 2);
2175 : 4534020 : return first;
2176 : : }
2177 : :
2178 : 795132 : value_t fl_liststar(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2179 : : {
2180 [ - + ]: 795132 : if (nargs == 1) return args[0];
2181 [ - + ]: 795132 : else if (nargs == 0) argcount(fl_ctx, "list*", nargs, 1);
2182 : 795132 : return _list(fl_ctx, args, nargs, 1);
2183 : : }
2184 : :
2185 : 0 : value_t fl_stacktrace(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2186 : : {
2187 : : (void)args;
2188 : 0 : argcount(fl_ctx, "stacktrace", nargs, 0);
2189 [ # # ]: 0 : return _stacktrace(fl_ctx, fl_ctx->throwing_frame ? fl_ctx->throwing_frame : fl_ctx->curr_frame);
2190 : : }
2191 : :
2192 : 45990200 : value_t fl_map1(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2193 : : {
2194 [ - + ]: 45990200 : if (nargs < 2)
2195 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "map: too few arguments");
2196 [ + + ]: 45990200 : if (!iscons(args[1])) return fl_ctx->NIL;
2197 : : value_t v;
2198 : 40204800 : uint32_t first, last, argSP = args-fl_ctx->Stack;
2199 [ + - + - ]: 40204800 : assert(args >= fl_ctx->Stack && argSP < fl_ctx->N_STACK);
2200 [ + + ]: 40204800 : if (nargs == 2) {
2201 [ - + ]: 40152600 : if (fl_ctx->SP+4 > fl_ctx->N_STACK) grow_stack(fl_ctx);
2202 : 40152600 : PUSH(fl_ctx, fl_ctx->Stack[argSP]);
2203 : 40152600 : PUSH(fl_ctx, car_(fl_ctx->Stack[argSP+1]));
2204 : 40152600 : v = _applyn(fl_ctx, 1);
2205 : 40152600 : POPN(fl_ctx, 2);
2206 : 40152600 : PUSH(fl_ctx, v);
2207 : 40152600 : v = mk_cons(fl_ctx);
2208 : 40152600 : car_(v) = POP(fl_ctx); cdr_(v) = fl_ctx->NIL;
2209 : 40152600 : PUSH(fl_ctx, v);
2210 : 40152600 : PUSH(fl_ctx, v);
2211 : 40152600 : first = fl_ctx->SP-2;
2212 : 40152600 : last = fl_ctx->SP-1;
2213 : 40152600 : fl_ctx->Stack[argSP+1] = cdr_(fl_ctx->Stack[argSP+1]);
2214 [ + + ]: 110126400 : while (iscons(fl_ctx->Stack[argSP+1])) {
2215 : 69973800 : PUSH(fl_ctx, fl_ctx->Stack[argSP]);
2216 : 69973800 : PUSH(fl_ctx, car_(fl_ctx->Stack[argSP+1]));
2217 : 69973800 : v = _applyn(fl_ctx, 1);
2218 : 69973800 : POPN(fl_ctx, 2);
2219 : 69973800 : PUSH(fl_ctx, v);
2220 : 69973800 : v = mk_cons(fl_ctx);
2221 : 69973800 : car_(v) = POP(fl_ctx); cdr_(v) = fl_ctx->NIL;
2222 : 69973800 : cdr_(fl_ctx->Stack[last]) = v;
2223 : 69973800 : fl_ctx->Stack[last] = v;
2224 : 69973800 : fl_ctx->Stack[argSP+1] = cdr_(fl_ctx->Stack[argSP+1]);
2225 : : }
2226 : 40152600 : POPN(fl_ctx, 2);
2227 : : }
2228 : : else {
2229 : : size_t i;
2230 [ - + ]: 52180 : while (fl_ctx->SP+nargs+1 > fl_ctx->N_STACK) grow_stack(fl_ctx);
2231 : 52180 : PUSH(fl_ctx, fl_ctx->Stack[argSP]);
2232 [ + + ]: 159420 : for(i=1; i < nargs; i++) {
2233 : 107240 : PUSH(fl_ctx, car(fl_ctx, fl_ctx->Stack[argSP+i]));
2234 : 107240 : fl_ctx->Stack[argSP+i] = cdr_(fl_ctx->Stack[argSP+i]);
2235 : : }
2236 : 52180 : v = _applyn(fl_ctx, nargs-1);
2237 : 52180 : POPN(fl_ctx, nargs);
2238 : 52180 : PUSH(fl_ctx, v);
2239 : 52180 : v = mk_cons(fl_ctx);
2240 : 52180 : car_(v) = POP(fl_ctx); cdr_(v) = fl_ctx->NIL;
2241 : 52180 : PUSH(fl_ctx, v);
2242 : 52180 : PUSH(fl_ctx, v);
2243 : 52180 : first = fl_ctx->SP-2;
2244 : 52180 : last = fl_ctx->SP-1;
2245 [ + + ]: 90544 : while (iscons(fl_ctx->Stack[argSP+1])) {
2246 : 38364 : PUSH(fl_ctx, fl_ctx->Stack[argSP]);
2247 [ + + ]: 121920 : for(i=1; i < nargs; i++) {
2248 : 83556 : PUSH(fl_ctx, car(fl_ctx, fl_ctx->Stack[argSP+i]));
2249 : 83556 : fl_ctx->Stack[argSP+i] = cdr_(fl_ctx->Stack[argSP+i]);
2250 : : }
2251 : 38364 : v = _applyn(fl_ctx, nargs-1);
2252 : 38364 : POPN(fl_ctx, nargs);
2253 : 38364 : PUSH(fl_ctx, v);
2254 : 38364 : v = mk_cons(fl_ctx);
2255 : 38364 : car_(v) = POP(fl_ctx); cdr_(v) = fl_ctx->NIL;
2256 : 38364 : cdr_(fl_ctx->Stack[last]) = v;
2257 : 38364 : fl_ctx->Stack[last] = v;
2258 : : }
2259 : 52180 : POPN(fl_ctx, 2);
2260 : : }
2261 : 40204800 : return fl_ctx->Stack[first];
2262 : : }
2263 : :
2264 : 61100400 : value_t fl_foreach(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
2265 : : {
2266 [ - + ]: 61100400 : if (nargs != 2)
2267 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "for-each: expected 2 arguments");
2268 : 61100400 : uint32_t argSP = args-fl_ctx->Stack;
2269 [ + - + - ]: 61100400 : assert(args >= fl_ctx->Stack && argSP < fl_ctx->N_STACK);
2270 [ - + ]: 61100400 : if (fl_ctx->SP+2 > fl_ctx->N_STACK) grow_stack(fl_ctx);
2271 : 61100400 : PUSH(fl_ctx, fl_ctx->T);
2272 : 61100400 : PUSH(fl_ctx, fl_ctx->T);
2273 [ + + ]: 182880600 : while (iscons(fl_ctx->Stack[argSP+1])) {
2274 : 121780400 : fl_ctx->Stack[fl_ctx->SP-2] = fl_ctx->Stack[argSP];
2275 : 121780400 : fl_ctx->Stack[fl_ctx->SP-1] = car_(fl_ctx->Stack[argSP+1]);
2276 : 121780400 : _applyn(fl_ctx, 1);
2277 : 121780400 : fl_ctx->Stack[argSP+1] = cdr_(fl_ctx->Stack[argSP+1]);
2278 : : }
2279 : 61100400 : POPN(fl_ctx, 2);
2280 : 61100400 : return fl_ctx->T;
2281 : : }
2282 : :
2283 : : static const builtinspec_t core_builtin_info[] = {
2284 : : { "function", fl_function },
2285 : : { "function:code", fl_function_code },
2286 : : { "function:vals", fl_function_vals },
2287 : : { "function:env", fl_function_env },
2288 : : { "function:name", fl_function_name },
2289 : : { "stacktrace", fl_stacktrace },
2290 : : { "gensym", fl_gensym },
2291 : : { "gensym?", fl_gensymp },
2292 : : { "hash", fl_hash },
2293 : : { "copy-list", fl_copylist },
2294 : : { "append", fl_append },
2295 : : { "list*", fl_liststar },
2296 : : { "map", fl_map1 },
2297 : : { "for-each", fl_foreach },
2298 : : { NULL, NULL }
2299 : : };
2300 : :
2301 : : // initialization -------------------------------------------------------------
2302 : :
2303 : : extern void builtins_init(fl_context_t *fl_ctx);
2304 : : extern void comparehash_init(fl_context_t *fl_ctx);
2305 : :
2306 : 30 : static void lisp_init(fl_context_t *fl_ctx, size_t initial_heapsize)
2307 : : {
2308 : : int i;
2309 : :
2310 : 30 : libsupport_init();
2311 : :
2312 : 30 : fl_ctx->SP = 0;
2313 : 30 : fl_ctx->curr_frame = 0;
2314 : 30 : fl_ctx->N_GCHND = 0;
2315 : 30 : fl_ctx->readstate = NULL;
2316 : 30 : fl_ctx->gensym_ctr = 0;
2317 : 30 : fl_ctx->gsnameno = 0;
2318 : :
2319 : : #ifdef MEMDEBUG2
2320 : : fl_ctx->tochain = NULL;
2321 : : fl_ctx->n_allocd = 0;
2322 : : #endif
2323 : :
2324 : 30 : fl_ctx->heapsize = initial_heapsize;
2325 : :
2326 : 30 : fl_ctx->fromspace = (unsigned char*)LLT_ALLOC(fl_ctx->heapsize);
2327 : : #ifdef MEMDEBUG
2328 : : fl_ctx->tospace = NULL;
2329 : : #else
2330 : 30 : fl_ctx->tospace = (unsigned char*)LLT_ALLOC(fl_ctx->heapsize);
2331 : : #endif
2332 : 30 : fl_ctx->curheap = fl_ctx->fromspace;
2333 : 30 : fl_ctx->lim = fl_ctx->curheap+fl_ctx->heapsize-sizeof(cons_t);
2334 : 30 : fl_ctx->consflags = bitvector_new(fl_ctx->heapsize/sizeof(cons_t), 1);
2335 : 30 : fl_print_init(fl_ctx);
2336 : 30 : comparehash_init(fl_ctx);
2337 : 30 : fl_ctx->N_STACK = 262144;
2338 : 30 : fl_ctx->Stack = (value_t*)malloc(fl_ctx->N_STACK*sizeof(value_t));
2339 : : // TODO: if fl_ctx->Stack == NULL
2340 [ - + ]: 30 : CHECK_ALIGN8(fl_ctx->Stack);
2341 : :
2342 : 30 : fl_ctx->NIL = builtin(OP_THE_EMPTY_LIST);
2343 : 30 : fl_ctx->T = builtin(OP_BOOL_CONST_T);
2344 : 30 : fl_ctx->F = builtin(OP_BOOL_CONST_F);
2345 : 30 : fl_ctx->FL_EOF = builtin(OP_EOF_OBJECT);
2346 : 30 : fl_ctx->LAMBDA = symbol(fl_ctx, "lambda"); fl_ctx->FUNCTION = symbol(fl_ctx, "function");
2347 : 30 : fl_ctx->QUOTE = symbol(fl_ctx, "quote"); fl_ctx->TRYCATCH = symbol(fl_ctx, "trycatch");
2348 : 30 : fl_ctx->BACKQUOTE = symbol(fl_ctx, "quasiquote"); fl_ctx->COMMA = symbol(fl_ctx, "unquote");
2349 : 30 : fl_ctx->COMMAAT = symbol(fl_ctx, "unquote-splicing"); fl_ctx->COMMADOT = symbol(fl_ctx, "unquote-nsplicing");
2350 : 30 : fl_ctx->IOError = symbol(fl_ctx, "io-error"); fl_ctx->ParseError = symbol(fl_ctx, "parse-error");
2351 : 30 : fl_ctx->TypeError = symbol(fl_ctx, "type-error"); fl_ctx->ArgError = symbol(fl_ctx, "arg-error");
2352 : 30 : fl_ctx->UnboundError = symbol(fl_ctx, "unbound-error");
2353 : 30 : fl_ctx->KeyError = symbol(fl_ctx, "key-error"); fl_ctx->OutOfMemoryError = symbol(fl_ctx, "memory-error");
2354 : 30 : fl_ctx->BoundsError = symbol(fl_ctx, "bounds-error");
2355 : 30 : fl_ctx->DivideError = symbol(fl_ctx, "divide-error");
2356 : 30 : fl_ctx->EnumerationError = symbol(fl_ctx, "enumeration-error");
2357 : 30 : fl_ctx->pairsym = symbol(fl_ctx, "pair");
2358 : 30 : fl_ctx->symbolsym = symbol(fl_ctx, "symbol"); fl_ctx->fixnumsym = symbol(fl_ctx, "fixnum");
2359 : 30 : fl_ctx->vectorsym = symbol(fl_ctx, "vector"); fl_ctx->builtinsym = symbol(fl_ctx, "builtin");
2360 : 30 : fl_ctx->booleansym = symbol(fl_ctx, "boolean"); fl_ctx->nullsym = symbol(fl_ctx, "null");
2361 : 30 : fl_ctx->definesym = symbol(fl_ctx, "define"); fl_ctx->defmacrosym = symbol(fl_ctx, "define-macro");
2362 : 30 : fl_ctx->forsym = symbol(fl_ctx, "for");
2363 : 30 : fl_ctx->setqsym = symbol(fl_ctx, "set!"); fl_ctx->evalsym = symbol(fl_ctx, "eval");
2364 : 30 : fl_ctx->vu8sym = symbol(fl_ctx, "vu8"); fl_ctx->fnsym = symbol(fl_ctx, "fn");
2365 : 30 : fl_ctx->nulsym = symbol(fl_ctx, "nul"); fl_ctx->alarmsym = symbol(fl_ctx, "alarm");
2366 : 30 : fl_ctx->backspacesym = symbol(fl_ctx, "backspace"); fl_ctx->tabsym = symbol(fl_ctx, "tab");
2367 : 30 : fl_ctx->linefeedsym = symbol(fl_ctx, "linefeed"); fl_ctx->vtabsym = symbol(fl_ctx, "vtab");
2368 : 30 : fl_ctx->pagesym = symbol(fl_ctx, "page"); fl_ctx->returnsym = symbol(fl_ctx, "return");
2369 : 30 : fl_ctx->escsym = symbol(fl_ctx, "esc"); fl_ctx->spacesym = symbol(fl_ctx, "space");
2370 : 30 : fl_ctx->deletesym = symbol(fl_ctx, "delete"); fl_ctx->newlinesym = symbol(fl_ctx, "newline");
2371 : 30 : fl_ctx->tsym = symbol(fl_ctx, "t"); fl_ctx->Tsym = symbol(fl_ctx, "T");
2372 : 30 : fl_ctx->fsym = symbol(fl_ctx, "f"); fl_ctx->Fsym = symbol(fl_ctx, "F");
2373 : 30 : set(fl_ctx->printprettysym=symbol(fl_ctx, "*print-pretty*"), fl_ctx->T);
2374 : 30 : set(fl_ctx->printreadablysym=symbol(fl_ctx, "*print-readably*"), fl_ctx->T);
2375 : 30 : set(fl_ctx->printwidthsym=symbol(fl_ctx, "*print-width*"), fixnum(fl_ctx->SCR_WIDTH));
2376 : 30 : set(fl_ctx->printlengthsym=symbol(fl_ctx, "*print-length*"), fl_ctx->F);
2377 : 30 : set(fl_ctx->printlevelsym=symbol(fl_ctx, "*print-level*"), fl_ctx->F);
2378 : 30 : fl_ctx->builtins_table_sym = symbol(fl_ctx, "*builtins*");
2379 : 30 : fl_ctx->lasterror = fl_ctx->NIL;
2380 : 30 : i = 0;
2381 [ + + ]: 1020 : for (i=OP_EQ; i <= OP_ASET; i++) {
2382 : 990 : setc(symbol(fl_ctx, builtin_names[i]), builtin(i));
2383 : : }
2384 : 30 : setc(symbol(fl_ctx, "eq"), builtin(OP_EQ));
2385 : 30 : setc(symbol(fl_ctx, "procedure?"), builtin(OP_FUNCTIONP));
2386 : 30 : setc(symbol(fl_ctx, "top-level-bound?"), builtin(OP_BOUNDP));
2387 : :
2388 : : #if defined(_OS_LINUX_)
2389 : 30 : set(symbol(fl_ctx, "*os-name*"), symbol(fl_ctx, "linux"));
2390 : : #elif defined(_OS_WINDOWS_)
2391 : : set(symbol(fl_ctx, "*os-name*"), symbol(fl_ctx, "win32"));
2392 : : #elif defined(_OS_DARWIN_)
2393 : : set(symbol(fl_ctx, "*os-name*"), symbol(fl_ctx, "macos"));
2394 : : #else
2395 : : set(symbol(fl_ctx, "*os-name*"), symbol(fl_ctx, "unknown"));
2396 : : #endif
2397 : :
2398 : 30 : fl_ctx->jl_sym = symbol(fl_ctx, "julia_value");
2399 : 30 : fl_ctx->jl_char_sym = symbol(fl_ctx, "julia_char");
2400 : :
2401 : 30 : fl_ctx->the_empty_vector = tagptr(alloc_words(fl_ctx, 1), TAG_VECTOR);
2402 : 30 : vector_setsize(fl_ctx->the_empty_vector, 0);
2403 : :
2404 : 30 : cvalues_init(fl_ctx);
2405 : :
2406 : : char exename[1024];
2407 : 30 : size_t exe_size = sizeof(exename) / sizeof(exename[0]);
2408 [ + - ]: 30 : if ( uv_exepath(exename, &exe_size) == 0 ) {
2409 : 30 : setc(symbol(fl_ctx, "*install-dir*"), cvalue_static_cstring(fl_ctx, strdup(dirname(exename))));
2410 : : }
2411 : :
2412 : 30 : fl_ctx->memory_exception_value = fl_list2(fl_ctx, fl_ctx->OutOfMemoryError,
2413 : : cvalue_static_cstring(fl_ctx, "out of memory"));
2414 : :
2415 : 30 : assign_global_builtins(fl_ctx, core_builtin_info);
2416 : :
2417 : 30 : fl_read_init(fl_ctx);
2418 : :
2419 : 30 : builtins_init(fl_ctx);
2420 : 30 : }
2421 : :
2422 : : // top level ------------------------------------------------------------------
2423 : :
2424 : 0 : value_t fl_toplevel_eval(fl_context_t *fl_ctx, value_t expr)
2425 : : {
2426 : 0 : return fl_applyn(fl_ctx, 1, symbol_value(fl_ctx->evalsym), expr);
2427 : : }
2428 : :
2429 : : extern void fl_init_julia_extensions(fl_context_t *fl_ctx);
2430 : :
2431 : 30 : void fl_init(fl_context_t *fl_ctx, size_t initial_heapsize)
2432 : : {
2433 : 30 : lisp_init(fl_ctx, initial_heapsize);
2434 : 30 : fl_init_julia_extensions(fl_ctx);
2435 : 30 : }
2436 : :
2437 : 30 : int fl_load_system_image_str(fl_context_t *fl_ctx, char *str, size_t len)
2438 : : {
2439 : 30 : value_t img = cvalue(fl_ctx, fl_ctx->iostreamtype, sizeof(ios_t));
2440 : 30 : ios_t *pi = value2c(ios_t*, img);
2441 : 30 : ios_static_buffer(pi, str, len);
2442 : :
2443 : 30 : return fl_load_system_image(fl_ctx, img);
2444 : : }
2445 : :
2446 : 30 : int fl_load_system_image(fl_context_t *fl_ctx, value_t sys_image_iostream)
2447 : : {
2448 : : value_t e;
2449 : : int saveSP;
2450 : : symbol_t *sym;
2451 : :
2452 : 30 : PUSH(fl_ctx, sys_image_iostream);
2453 : 30 : saveSP = fl_ctx->SP;
2454 [ + - + + ]: 60 : FL_TRY(fl_ctx) {
2455 : : while (1) {
2456 : 30 : e = fl_read_sexpr(fl_ctx, fl_ctx->Stack[fl_ctx->SP-1]);
2457 [ - + ]: 30 : if (ios_eof(value2c(ios_t*,fl_ctx->Stack[fl_ctx->SP-1]))) break;
2458 [ - + - - ]: 30 : if (isfunction(e)) {
2459 : : // stage 0 format: series of thunks
2460 : 0 : PUSH(fl_ctx, e);
2461 : 0 : (void)_applyn(fl_ctx, 0);
2462 : 0 : fl_ctx->SP = saveSP;
2463 : : }
2464 : : else {
2465 : : // stage 1 format: list alternating symbol/value
2466 [ + + ]: 25620 : while (iscons(e)) {
2467 : 25590 : sym = tosymbol(fl_ctx, car_(e), "bootstrap");
2468 : 25590 : e = cdr_(e);
2469 : 25590 : (void)tocons(fl_ctx, e, "bootstrap");
2470 : 25590 : sym->binding = car_(e);
2471 : 25590 : e = cdr_(e);
2472 : : }
2473 : 30 : break;
2474 : : }
2475 : : }
2476 : : }
2477 [ # # ]: 0 : FL_CATCH(fl_ctx) {
2478 : 0 : ios_puts("fatal error during bootstrap:\n", ios_stderr);
2479 : 0 : fl_print(fl_ctx, ios_stderr, fl_ctx->lasterror);
2480 : 0 : ios_putc('\n', ios_stderr);
2481 : 0 : return 1;
2482 : : }
2483 : 30 : ios_close(value2c(ios_t*,fl_ctx->Stack[fl_ctx->SP-1]));
2484 : 30 : POPN(fl_ctx, 1);
2485 : 30 : return 0;
2486 : : }
2487 : :
2488 : : #ifdef __cplusplus
2489 : : }
2490 : : #endif
|
