// word-code ( word -- start end )
// Allocates memory (from_unsigned_cell allocates)
void factor_vm::primitive_word_code() {
data_root<word> w(ctx->pop(), this);
check_tagged(w);
ctx->push(from_unsigned_cell(w->entry_point));
ctx->push(from_unsigned_cell((cell)w->code() + w->code()->size()));
}
// Allocates memory (from_unsigned_cell())
void factor_vm::primitive_fread() {
FILE* file = pop_file_handle();
void* buf = (void*)alien_offset(ctx->pop());
cell size = unbox_array_size();
if (size == 0) {
ctx->push(from_unsigned_cell(0));
return;
}
size_t c = safe_fread(buf, 1, size, file);
if (c == 0 || feof(file))
clearerr(file);
ctx->push(from_unsigned_cell(c));
}
/* word-code ( word -- start end ) */
void factor_vm::primitive_word_code()
{
data_root<word> w(ctx->pop(),this);
w.untag_check(this);
if(counting_profiler_p)
{
ctx->push(from_unsigned_cell((cell)w->profiling->entry_point()));
ctx->push(from_unsigned_cell((cell)w->profiling + w->profiling->size()));
}
else
{
ctx->push(from_unsigned_cell((cell)w->code->entry_point()));
ctx->push(from_unsigned_cell((cell)w->code + w->code->size()));
}
}
/* Allocates memory */
void factor_vm::memory_signal_handler_impl() {
if (code->safepoint_p(signal_fault_addr)) {
safepoint.handle_safepoint(this, signal_fault_pc);
}
else {
vm_error_type type = ctx->address_to_error(signal_fault_addr);
cell number = from_unsigned_cell(signal_fault_addr);
general_error(type, number, false_object);
}
if (!signal_resumable) {
/* In theory we should only get here if the callstack overflowed during a
safepoint */
general_error(ERROR_CALLSTACK_OVERFLOW, false_object, false_object);
}
}
void factor_vm::memory_protection_error(cell pc, cell addr)
{
if(code->safepoint_p(addr))
safepoint.handle_safepoint(this, pc);
else if(ctx->datastack_seg->underflow_p(addr))
general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object);
else if(ctx->datastack_seg->overflow_p(addr))
general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object);
else if(ctx->retainstack_seg->underflow_p(addr))
general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object);
else if(ctx->retainstack_seg->overflow_p(addr))
general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object);
else if(ctx->callstack_seg->underflow_p(addr))
general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object);
else if(ctx->callstack_seg->overflow_p(addr))
general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object);
else
general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object);
}
// address of an object representing a C pointer. Explicitly throw an error
// if the object is a byte array, as a sanity check.
// Allocates memory (from_unsigned_cell can allocate)
void factor_vm::primitive_alien_address() {
ctx->replace(from_unsigned_cell((cell)pinned_alien_offset(ctx->peek())));
}
/* Allocates memory */
void factor_vm::synchronous_signal_handler_impl() {
general_error(ERROR_SIGNAL, from_unsigned_cell(signal_number), false_object);
}
// Allocates memory
void factor_vm::primitive_size() {
ctx->replace(from_unsigned_cell(object_size(ctx->peek())));
}
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
void factor_vm::primitive_alien_address()
{
ctx->push(from_unsigned_cell((cell)pinned_alien_offset(ctx->pop())));
}
// Allocates memory (from_unsigned_cell)
void factor_vm::primitive_quotation_code() {
data_root<quotation> quot(ctx->pop(), this);
ctx->push(from_unsigned_cell(quot->entry_point));
ctx->push(from_unsigned_cell((cell)quot->code() + quot->code()->size()));
}
void factor_vm::primitive_size()
{
ctx->push(from_unsigned_cell(object_size(ctx->pop())));
}
void factor_vm::signal_error(cell signal)
{
general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object);
}