3 INLINE void execute(F_WORD* word)
5 ((XT)(word->xt))(word);
8 INLINE void push_callframe(void)
11 put(cs - CELLS * 2,callframe);
12 put(cs - CELLS,callframe_scan);
13 put(cs,callframe_end);
16 INLINE void set_callframe(CELL quot)
18 F_ARRAY *untagged = (F_ARRAY*)UNTAG(quot);
19 type_check(QUOTATION_TYPE,quot);
21 callframe_scan = AREF(untagged,0);
22 callframe_end = AREF(untagged,array_capacity(untagged));
30 /* tail call optimization */
31 if(callframe_scan < callframe_end)
37 /* Called from interpreter() */
38 void handle_error(void)
42 if(thrown_keep_stacks)
51 /* Notify any 'catch' blocks */
53 set_callframe(userenv[BREAK_ENV]);
58 void interpreter_loop(void)
64 if(callframe_scan == callframe_end)
66 if(cs_bot - cs == CELLS)
69 callframe_end = get(cs);
70 callframe_scan = get(cs - CELLS);
71 callframe = get(cs - CELLS * 2);
76 next = get(callframe_scan);
77 callframe_scan += CELLS;
82 execute(untag_word_fast(next));
85 dpush(untag_wrapper_fast(next)->object);
94 void interpreter(void)
96 SETJMP(stack_chain->toplevel);
101 /* Called by compiled callbacks after nest_stacks() and boxing registers */
102 void run_callback(CELL quot)
108 /* XT of deferred words */
109 void undefined(F_WORD* word)
111 general_error(ERROR_UNDEFINED_WORD,tag_word(word),F,true);
114 /* XT of compound definitions */
115 void docol(F_WORD* word)
120 /* pushes word parameter */
121 void dosym(F_WORD* word)
126 void primitive_execute(void)
128 execute(untag_word(dpop()));
131 void primitive_call(void)
136 void primitive_ifte(void)
139 call(get(ds + CELLS) == F ? get(ds + CELLS * 3) : get(ds + CELLS * 2));
142 void primitive_dispatch(void)
144 F_ARRAY *a = untag_array_fast(dpop());
145 F_FIXNUM n = untag_fixnum_fast(dpop());
146 call(get(AREF(a,n)));
149 void primitive_getenv(void)
151 F_FIXNUM e = untag_fixnum_fast(dpeek());
155 void primitive_setenv(void)
157 F_FIXNUM e = untag_fixnum_fast(dpop());
162 void primitive_exit(void)
164 exit(to_fixnum(dpop()));
167 void primitive_os_env(void)
173 name = unbox_char_string();
174 value = getenv(name);
178 box_char_string(getenv(name));
181 void primitive_eq(void)
185 drepl((lhs == rhs) ? T : F);
188 void primitive_millis(void)
191 dpush(tag_bignum(s48_long_long_to_bignum(current_millis())));
194 void primitive_type(void)
196 drepl(tag_fixnum(type_of(dpeek())));
199 void primitive_tag(void)
201 drepl(tag_fixnum(TAG(dpeek())));
204 void primitive_slot(void)
206 F_FIXNUM slot = untag_fixnum_fast(dpop());
207 CELL obj = UNTAG(dpop());
208 dpush(get(SLOT(obj,slot)));
211 void primitive_set_slot(void)
213 F_FIXNUM slot = untag_fixnum_fast(dpop());
214 CELL obj = UNTAG(dpop());
216 put(SLOT(obj,slot),value);
220 void primitive_integer_slot(void)
222 F_FIXNUM slot = untag_fixnum_fast(dpop());
223 CELL obj = UNTAG(dpop());
224 dpush(tag_cell(get(SLOT(obj,slot))));
227 void primitive_set_integer_slot(void)
229 F_FIXNUM slot = untag_fixnum_fast(dpop());
230 CELL obj = UNTAG(dpop());
231 F_FIXNUM value = to_cell(dpop());
232 put(SLOT(obj,slot),value);
237 CELL size = object_size(obj);
239 void *new_obj = allot(size);
240 return RETAG(memcpy(new_obj,(void*)UNTAG(obj),size),tag);
243 void primitive_clone(void)
246 drepl(clone(dpeek()));
249 void fatal_error(char* msg, CELL tagged)
251 fprintf(stderr,"Fatal error: %s %lx\n",msg,tagged);
255 void critical_error(char* msg, CELL tagged)
257 fprintf(stderr,"Critical error: %s %lx\n",msg,tagged);
261 void early_error(CELL error)
263 if(userenv[BREAK_ENV] == F)
265 /* Crash at startup */
266 fprintf(stderr,"Error during startup: ");
268 fprintf(stderr,"\n");
273 void throw_error(CELL error, bool keep_stacks)
278 thrown_error = error;
279 thrown_keep_stacks = keep_stacks;
283 /* Return to interpreter() function */
284 LONGJMP(stack_chain->toplevel,1);
287 void primitive_throw(void)
289 throw_error(dpop(),true);
292 void primitive_die(void)
297 void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, bool keep_stacks)
299 throw_error(make_array_4(userenv[ERROR_ENV],
300 tag_fixnum(error),arg1,arg2),keep_stacks);
303 void memory_protection_error(void *addr, int signal)
305 if(in_page(addr, (void *) ds_bot, 0, -1))
306 general_error(ERROR_DS_UNDERFLOW,F,F,false);
307 else if(in_page(addr, (void *) ds_bot, ds_size, 0))
308 general_error(ERROR_DS_OVERFLOW,F,F,false);
309 else if(in_page(addr, (void *) rs_bot, 0, -1))
310 general_error(ERROR_RS_UNDERFLOW,F,F,false);
311 else if(in_page(addr, (void *) rs_bot, rs_size, 0))
312 general_error(ERROR_RS_OVERFLOW,F,F,false);
313 else if(in_page(addr, (void *) cs_bot, 0, -1))
314 general_error(ERROR_CS_UNDERFLOW,F,F,false);
315 else if(in_page(addr, (void *) cs_bot, cs_size, 0))
316 general_error(ERROR_CS_OVERFLOW,F,F,false);
318 signal_error(signal);
321 /* It is not safe to access 'ds' from a signal handler, so we just not
323 void signal_error(int signal)
325 general_error(ERROR_SIGNAL,tag_fixnum(signal),F,false);
328 void type_error(CELL type, CELL tagged)
330 general_error(ERROR_TYPE,tag_fixnum(type),tagged,true);