/* make an alien and push */
void factorvm::box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
else
dpush(allot_alien(F,(cell)ptr));
}
/*
All extended commands are handled here. This is a really long
switch statement. It could be made shorter by making the contents function
calls but (outside of a good optimizer) this would incur additional overhead.
We want to be as fast as possible.
If you are reading this, but haven't looked at uForth scripts, you are
missing a lot of context. This is just a bunch of utility calls that will
make more sense when browsed within the context of a calling script!
*/
uforth_stat c_ext_handle_cmds(CELL n) {
CELL r1, r2,r3; /* NOTE: THESE ARE 16 bit values! */
char *str1;
switch (n) {
case UF_INTERP: /* recursively call the uforth interpreter */
r1 = dpop();
str1 = uforth_count_str(r1,&r1);
str1[r1] = '\0';
dpush(uforth_interpret(str1));
break;
case UF_SUBSTR: /* return a substring of the uForth string */
r1 = dpop(); /* addr */
r2 = dpop(); /* length */
r3 = dpop(); /* start */
str1 = uforth_count_str(r1,&r1);
if (r1 < r2) r2 = r1;
PAD_STRLEN = r2;
memcpy(PAD_STR, str1 + r3, r2);
dpush(RAM_START_IDX+PAD_ADDR);
break;
case UF_NUM_TO_STR: /* 32bit to string */
{
char num[12];
i32toa(dpop32(),num,uforth_uram->base);
PAD_STRLEN=strlen(num);
memcpy(PAD_STR, num, PAD_SIZE);
dpush(RAM_START_IDX+PAD_ADDR);
}
break;
default:
return E_ABORT;
}
return OK;
}
/* make an alien and push */
void box_alien(void *ptr)
{
if(ptr == NULL)
dpush(F);
else
dpush(allot_alien(F,(CELL)ptr));
}
void factor_vm::primitive_disable_gc_events()
{
if(gc_events)
{
growable_array result(this);
std::vector<gc_event> *gc_events = this->gc_events;
this->gc_events = NULL;
std::vector<gc_event>::const_iterator iter = gc_events->begin();
std::vector<gc_event>::const_iterator end = gc_events->end();
for(; iter != end; iter++)
{
gc_event event = *iter;
byte_array *obj = byte_array_from_value(&event);
result.add(tag<byte_array>(obj));
}
result.trim();
dpush(result.elements.value());
delete this->gc_events;
}
else
dpush(false_object);
}
inline void factorvm::vmprim_dll_validp()
{
cell library = dpop();
if(library == F)
dpush(T);
else
dpush(untag_check<dll>(library)->dll == NULL ? F : T);
}
/* Push the free space and total size of the code heap */
void factor_vm::primitive_code_room()
{
cell used, total_free, max_free;
code->heap_usage(&used,&total_free,&max_free);
dpush(tag_fixnum(code->seg->size / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
/* Push the free space and total size of the code heap */
void primitive_code_room(void)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
int dtadd(datrie *pvdt, const char *word, const void *wextra, uint32_t exlen) {
datrie_t *pdt = (datrie_t *)pvdt;
int wclen = 0;
wchar_t *wstr = dec_word(word, pdt->encode_, &wclen);
int ret = dpush(pdt->pwarry_, wstr, sizeof(wchar_t) * (wclen + 1));
free(wstr);
if (ret > 0 && pdt->pextra_) {
if (wextra) {
ret = dpush(pdt->pextra_, wextra, exlen);
} else {
ret = dpush(pdt->pextra_, (const void *)"", 1);
}
}
return ret;
}
void factor_vm::primitive_resize_array()
{
data_root<array> a(dpop(),this);
a.untag_check(this);
cell capacity = unbox_array_size();
dpush(tag<array>(reallot_array(a.untagged(),capacity)));
}
/* notationSwitch: Pass this a string which might be a notation switch
statement (eg %edensl). This returns non-zero if the switch to
this new notation was successful. Replaces Chris Brown's
setcurrentnot function. [Ash] */
int notationSwitch(char * s) {
Datum d, ret;
char *t;
extern char *libLocation;
extern int TopEntryStack;
if ((s[0] != '%') || !libLocation) return 0;
/* This code leads to the Eden notationSwitch failing to compare
7-character-long strings and find them equal, for some strange
reason, so notations with names of length 6 don't work.
t = getheap(strlen(s));
strcpy(t, s);
dpush(d, STRING, t);
*/
dpush(d, STRING, s);
makearr(1);
pushMasterStack("notationSwitch");
call(lookup("notationSwitch", basecontext), pop(), 0);
popMasterStack();
ret = pop();
mustint(ret);
/* fprintf(stderr, "RET %d\n", ret.u.i); */
return ret.u.i;
}
void factor_vm::primitive_array()
{
data_root<object> fill(dpop(),this);
cell capacity = unbox_array_size();
array *new_array = allot_uninitialized_array<array>(capacity);
memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
dpush(tag<array>(new_array));
}
/* push a new tuple on the stack, filling its slots from the stack */
inline void factorvm::vmprim_tuple_boa()
{
gc_root<tuple_layout> layout(dpop(),this);
gc_root<tuple> t(allot_tuple(layout.value()),this);
cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
ds -= size;
dpush(t.value());
}
/* open a native library and push a handle */
inline void factorvm::vmprim_dlopen()
{
gc_root<byte_array> path(dpop(),this);
path.untag_check(this);
gc_root<dll> library(allot<dll>(sizeof(dll)),this);
library->path = path.value();
ffi_dlopen(library.untagged());
dpush(library.value());
}
inline void factorvm::vmprim_tuple()
{
gc_root<tuple_layout> layout(dpop(),this);
tuple *t = allot_tuple(layout.value());
fixnum i;
for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
t->data()[i] = F;
dpush(tag<tuple>(t));
}
void factor_vm::primitive_callstack_to_array()
{
gc_root<callstack> callstack(dpop(),this);
stack_frame_accumulator accum(this);
iterate_callstack_object(callstack.untagged(),accum);
accum.frames.trim();
dpush(accum.frames.elements.value());
}
uforth_stat c_handle(void) {
DCELL r2, r1 = dpop();
char *str;
FILE *fp;
static char buf[80*2];
switch(r1) {
case UF_EMIT: /* emit */
txc(dpop()&0xff);
break;
case UF_KEY: /* key */
dpush((CELL)rxc());
break;
case UF_TYPE: /* type */
r1 = dpop();
r2 = dpop();
if (r2 >= RAM_START_IDX) {
str = (char*)&uforth_ram[r2-RAM_START_IDX];
} else {
str = (char*)&(uforth_dict[r2]);
}
txs(str,r1);
break;
case UF_SAVE_IMAGE: /* save image */
{
uforth_next_word();
strncpy(buf, uforth_iram->currword, uforth_iram->currwordlen);
buf[uforth_iram->currwordlen] = '\0';
printf("Saving dictionary into %s\n", buf);
fp = fopen(buf, "w+");
fwrite(dict, (dict_here())*sizeof(CELL) ,1,fp);
fclose(fp);
}
break;
case UF_INCLUDE: /* include */
{
uforth_next_word();
strncpy(buf,uforth_iram->currword, uforth_iram->currwordlen);
buf[uforth_iram->currwordlen] = '\0';
printf(" Loading %s\n",buf);
fp = fopen(buf, "r");
if (fp != NULL) {
interpret_from(fp);
fclose(fp);
} else {
printf("File not found: %s\n", buf);
}
}
break;
default:
return c_ext_handle_cmds(r1);
}
return OK;
}
void factor_vm::primitive_callstack()
{
stack_frame *top = second_from_top_stack_frame();
stack_frame *bottom = ctx->callstack_bottom;
fixnum size = std::max((fixnum)0,(fixnum)bottom - (fixnum)top);
callstack *stack = allot_callstack(size);
memcpy(stack->top(),top,size);
dpush(tag<callstack>(stack));
}
void primitive_fread(void)
{
FILE* file = unbox_alien();
CELL size = unbox_array_size();
if(size == 0)
{
dpush(tag_object(allot_string(0,0)));
return;
}
F_BYTE_ARRAY *buf = allot_byte_array(size);
for(;;)
{
int c = fread(buf + 1,1,size,file);
if(c <= 0)
{
if(feof(file))
{
dpush(F);
break;
}
else
io_error();
}
else
{
if(c != size)
{
REGISTER_UNTAGGED(buf);
F_BYTE_ARRAY *new_buf = allot_byte_array(c);
UNREGISTER_UNTAGGED(buf);
memcpy(new_buf + 1, buf + 1,c);
buf = new_buf;
}
dpush(tag_object(buf));
break;
}
}
}
void factor_vm::primitive_inline_cache_stats()
{
growable_array stats(this);
stats.add(allot_cell(cold_call_to_ic_transitions));
stats.add(allot_cell(ic_to_pic_transitions));
stats.add(allot_cell(pic_to_mega_transitions));
cell i;
for(i = 0; i < 4; i++)
stats.add(allot_cell(pic_counts[i]));
stats.trim();
dpush(stats.elements.value());
}
uforth_stat uforth_interpret(char *str) {
uforth_stat stat;
char *word;
CELL wd_idx;
char immediate = 0;
char primitive = 0;
uforth_iram->inbufptr = str;
while(*(word = uforth_next_word()) != 0) {
wd_idx = find_word(word,uforth_iram->currwordlen,0,&immediate,&primitive);
switch (uforth_iram->compiling) {
case 0: /* interpret mode */
if (wd_idx == 0) { /* number or trash */
DCELL num = parse_num(word,uforth_uram->base);
if (num == 0 && word[0] != '0') {
uforth_abort_request(ABORT_NAW);
uforth_abort();
return E_NOT_A_WORD;
}
if (abs32(num) > (int32_t)MAX_CELL_NUM){
dpush32(num);
} else {
dpush(num);
}
} else {
stat = exec(wd_idx,primitive,uforth_uram->ridx-1);
if (stat != OK) {
uforth_abort();
uforth_abort_clr();
return stat;
}
}
break;
case 1: /* in the middle of a colon def */
if (wd_idx == 0) { /* number or trash */
DCELL num = parse_num(word,uforth_uram->base);
if (num == 0 && word[0] != '0') {
uforth_abort_request(ABORT_NAW);
uforth_abort();
dict_end_def();
return E_NOT_A_WORD;
}
/* OPTIMIZATION: Only DLIT big numbers */
if (num < 0 || abs32(num) > (int32_t)MAX_CELL_NUM){
dict_append(DLIT);
dict_append(((uint32_t)num)>>16);
dict_append(((uint16_t)num)&0xffff);
} else {
dict_append(LIT);
dict_append(num);
}
} else if (word[0] == ';') { /* exit from a colon def */
void factor_vm::primitive_callstack()
{
stack_frame *top = capture_start();
stack_frame *bottom = stack_chain->callstack_bottom;
fixnum size = (cell)bottom - (cell)top;
if(size < 0)
size = 0;
callstack *stack = allot_callstack(size);
memcpy(stack->top(),top,size);
dpush(tag<callstack>(stack));
}
/* make an alien pointing at an offset of another alien */
inline void factorvm::vmprim_displaced_alien()
{
cell alien = dpop();
cell displacement = to_cell(dpop());
if(alien == F && displacement == 0)
dpush(F);
else
{
switch(tagged<object>(alien).type())
{
case BYTE_ARRAY_TYPE:
case ALIEN_TYPE:
case F_TYPE:
dpush(allot_alien(alien,displacement));
break;
default:
type_error(ALIEN_TYPE,alien);
break;
}
}
}
bool factor_vm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
if(depth < 0)
return false;
else
{
array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1,(void*)bottom,depth);
dpush(tag<array>(a));
return true;
}
}
/* Used to implement call( */
void factor_vm::primitive_check_datastack()
{
fixnum out = to_fixnum(dpop());
fixnum in = to_fixnum(dpop());
fixnum height = out - in;
array *saved_datastack = untag_check<array>(dpop());
fixnum saved_height = array_capacity(saved_datastack);
fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell);
if(current_height - height != saved_height)
dpush(false_object);
else
{
fixnum i;
for(i = 0; i < saved_height - in; i++)
{
if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i))
{
dpush(false_object);
return;
}
}
dpush(true_object);
}
}
void primitive_fgetc(void)
{
FILE* file = unbox_alien();
for(;;)
{
int c = fgetc(file);
if(c == EOF)
{
if(feof(file))
{
dpush(F);
break;
}
else
io_error();
}
else
{
dpush(tag_fixnum(c));
break;
}
}
}
void
dclear( /* delete variable definitions of name */
char *name
)
{
EPNODE *ep;
while ((ep = dpop(name)) != NULL) {
if (ep->type == ':') {
dpush(name, ep); /* don't clear constants */
return;
}
epfree(ep);
}
}
int dsortidx(darray *pvda, int idxs[], int sze) {
darray_t *pda = (darray_t *)pvda;
if (sze != pda->elem_num_) {
return 0;
}
darray_t *ptmp = (darray_t *)dclone(pda);
ptmp = dclear(ptmp);
int i;
for (i = 0; i < sze; ++i) {
int id = idxs[i];
dpush(ptmp, dgetp(pda, id), dgetlen(pda, id));
}
pda = drefer(pda, ptmp);
free(ptmp);
return 1;
}
void throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(userenv[BREAK_ENV] != F)
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
/* Reset local roots */
gc_locals = gc_locals_region->start - sizeof(cell);
gc_bignums = gc_bignums_region->start - sizeof(cell);
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
fix_stacks();
dpush(error);
/* Errors thrown from C code pass NULL for this parameter.
Errors thrown from Factor code, or signal handlers, pass the
actual stack pointer at the time, since the saved pointer is
not necessarily up to date at that point. */
if(callstack_top)
{
callstack_top = fix_callstack_top(callstack_top,
stack_chain->callstack_bottom);
}
else
callstack_top = stack_chain->callstack_top;
throw_impl(userenv[BREAK_ENV],callstack_top);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
else
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("early_error: ");
print_obj(error);
nl();
factorbug();
}
}
void factor_vm::throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
if(!current_gc && to_boolean(special_objects[OBJ_BREAK]))
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
/* Reset local roots */
data_roots.clear();
bignum_roots.clear();
code_roots.clear();
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
fix_stacks();
dpush(error);
/* Errors thrown from C code pass NULL for this parameter.
Errors thrown from Factor code, or signal handlers, pass the
actual stack pointer at the time, since the saved pointer is
not necessarily up to date at that point. */
if(callstack_top)
callstack_top = fix_callstack_top(callstack_top,ctx->callstack_bottom);
else
callstack_top = ctx->callstack_top;
throw_impl(special_objects[OBJ_BREAK],callstack_top,this);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
else
{
std::cout << "You have triggered a bug in Factor. Please report.\n";
std::cout << "early_error: ";
print_obj(error);
std::cout << std::endl;
factorbug();
}
}
void
getstatement(void) /* get next statement */
{
EPNODE *ep;
char *qname;
VARDEF *vdef;
if (nextc == ';') { /* empty statement */
scan();
return;
}
if (esupport&E_OUTCHAN &&
nextc == '$') { /* channel assignment */
ep = getchan();
addchan(ep);
} else { /* ordinary definition */
ep = getdefn();
qname = qualname(dname(ep), 0);
if (esupport&E_REDEFW && (vdef = varlookup(qname)) != NULL) {
if (vdef->def != NULL && epcmp(ep, vdef->def)) {
wputs(qname);
if (vdef->def->type == ':')
wputs(": redefined constant expression\n");
else
wputs(": redefined\n");
} else if (ep->v.kid->type == FUNC && vdef->lib != NULL) {
wputs(qname);
wputs(": definition hides library function\n");
}
}
if (ep->type == ':')
dremove(qname);
else
dclear(qname);
dpush(qname, ep);
}
if (nextc != EOF) {
if (nextc != ';')
syntax("';' expected");
scan();
}
}