void decode( char *instr, _decoder_output *out){
if(instr){
get_opcode(instr,out);
get_operands(instr,out);
}
else{
out->opc[0] = '\0';
}
set_reg_val(regfile+REG_NEXTPC,get_reg_val(REG_NEXTPC)+1);
}
data_t *eval(const data_t *exp, data_t *env) {
if(eval_plz_die) {
eval_plz_die = 0;
ExitThread(0);
}
if(is_self_evaluating(exp))
return (data_t*)exp;
if(is_variable(exp))
return lookup_variable_value(exp, env);
if(is_quoted_expression(exp))
return get_text_of_quotation(exp);
if(is_assignment(exp))
return eval_assignment(exp, env);
if(is_definition(exp))
return eval_definition(exp, env);
if(is_if(exp))
return eval_if(exp, env);
if(is_lambda(exp))
return make_procedure(get_lambda_parameters(exp), get_lambda_body(exp), env);
if(is_begin(exp))
return eval_sequence(get_begin_actions(exp), env);
if(is_cond(exp))
return eval(cond_to_if(exp), env);
if(is_letrec(exp))
return eval(letrec_to_let(exp), env);
if(is_let_star(exp))
return eval(let_star_to_nested_lets(exp), env);
if(is_let(exp))
return eval(let_to_combination(exp), env);
if(is_application(exp))
return apply(
eval(get_operator(exp), env),
get_list_of_values(get_operands(exp), env));
printf("Unknown expression type -- EVAL '");
return make_symbol("error");
}
mword *_babel(bvm_cache *this_bvm, mword *loaded_bvm, mword *arg_stack, mword *sym_table){ // _babel#
bvm_cache new_bvm;
bvm_cache *new_bvm_ptr = &new_bvm;
mword *result = nil;
cache_new(this_bvm, new_bvm_ptr, loaded_bvm);
mword *self = tptr_detag(new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self)); // Could blow up due to mem_alloc()
if( !trie_exists(new_bvm_ptr, self, BABEL_SYM_BVM_INITD, nil) ){
trie_insert( new_bvm_ptr, self, BABEL_SYM_BVM_INITD, nil, _val(new_bvm_ptr,1) );
// trie_insert( new_bvm_ptr, self, BABEL_SYM_BVM_INITD, nil, _val(new_bvm_ptr,0) );
}
mword *bvm_initd = rci(cache_read_from_bvm(new_bvm_ptr, BABEL_SYM_BVM_INITD),0);
if(!rcl(bvm_initd,0)){
bvm_new(new_bvm_ptr);
lcl(bvm_initd,0) = 1;
}
else{
cache_update(new_bvm_ptr);
}
if( !trie_exists(new_bvm_ptr, self, BABEL_SYM_CODE_RESTART_POINT, nil) ){
trie_insert( new_bvm_ptr, self, BABEL_SYM_CODE_RESTART_POINT, nil, rci(new_bvm_ptr->code_ptr,0));
}
new_bvm_ptr->flags->BVM_CACHE_DIRTY = FLAG_CLR;
new_bvm_ptr->flags->BVM_CACHE_INVALID = FLAG_CLR;
cache_flush(this_bvm);
if(!is_nil(sym_table)){
trie_insert(new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self), BABEL_SYM_SOFT_ROOT, nil, sym_table);
}
trie_insert(new_bvm_ptr, tptr_detag(new_bvm_ptr, new_bvm_ptr->self), BABEL_SYM_PARENT_BVM, nil, this_bvm->self);
new_bvm_ptr->flags->BVM_CODE_LIST_EMPTY = FLAG_CLR;
while(!is_nil(arg_stack)){ // give the arg-list onto the BVM's dstack
interp_push_operand(new_bvm_ptr, rci(arg_stack, 0));
arg_stack = rci(arg_stack,1);
}
interp_core(new_bvm_ptr);
cache_cp(new_bvm_ptr, this_bvm); //update flags and interp
this_bvm->self = _ith( this_bvm,
trie_lookup_hash(
new_bvm_ptr,
tptr_detag(new_bvm_ptr, new_bvm_ptr->self),
BABEL_SYM_PARENT_BVM,
nil),
2 );
cache_update(this_bvm);
this_bvm->flags->BVM_CACHE_DIRTY = FLAG_CLR;
this_bvm->flags->BVM_CACHE_INVALID = FLAG_CLR;
//copy TOS from new_bvm to this_bvm
oinfo oi;
oi.default_data = nil;
oi.required_tag = nil;
oi.mask = OI_MASK_ANY;
oi.min_size = 0;
oi.max_size = 1;
if( new_bvm_ptr->flags->BVM_RETURN_TOS_ON_EXIT == FLAG_SET
&&
(new_bvm_ptr->flags->BVM_CODE_LIST_EMPTY == FLAG_SET
||
(get_advance_type(new_bvm_ptr) == BVM_RETURN))){
get_operands(new_bvm_ptr,1,&oi);
result = oi.data;
stack_pop(new_bvm_ptr,rci(new_bvm_ptr->dstack_ptr,0));
// stack_push(this_bvm,
// rci(this_bvm->dstack_ptr,0),
// stack_new_entry(
// this_bvm,
// oi.data,
// nil));
}
// Reset all flags in case of re-entry
new_bvm_ptr->flags->BVM_RETURN_TOS_ON_EXIT = FLAG_CLR; // FIXME: This restore to previous value, not force-clear
new_bvm_ptr->flags->BVM_CODE_LIST_EMPTY = FLAG_CLR;
if(get_advance_type(new_bvm_ptr) == BVM_RETURN){
set_advance_type(new_bvm_ptr, BVM_ADVANCE);
}
this_bvm->flags->BVM_RETURN_TOS_ON_EXIT = FLAG_CLR;
this_bvm->flags->BVM_CODE_LIST_EMPTY = FLAG_CLR;
return result;
}
/** Parse text file and create
* list elements for each instruction
* appends instructions to the end of the list it gets
* so that you can call this more than once, to include
* more than one file
* if you call it passing a root that is null, it will return
* the beginning of the list
* if you pass it something other than null, it returns a pointer
* to the last link of the list
*/
struct instruction *parse_source(FILE *infile, struct instruction* initial_root, struct tab_entry *tabroot)
{
struct instruction *cur_old =NULL, *cur = NULL;
struct instruction *inst_root;
char buffer[INSTRUCTION_BUFFER_SIZE];
char b[INSTRUCTION_BUFFER_SIZE];
char *buf, *ptr;
int instructions = 0;
int cur_op_num;
inst_root = initial_root;
buf = b;
while (fgets(buffer, INSTRUCTION_BUFFER_SIZE, infile))
{
strip_comment(buffer);
linenumber++;
if (cur == NULL)
cur = new_instruction();
if (isblank(buffer[0]) || (buffer[0] == '\n') || (buffer[0] == '#') || (buffer[0] == '.')) {
if (buffer[0] == '#') //make preprocessor directives .<directive>
buffer[0] = '.';
/** split line, get instruction and operands */
if ((buf = (char *) strtok(buffer, whitespace))) {
instructions++;
if (!inst_root)
inst_root = cur;
if (cur_old)
cur_old->next = cur;
capitalize(buf);
strncpy(cur->mnumonic, buf, MNUMONIC_TXT_LENGTH);
get_operands(cur);
}
calculate_opcode(tabroot, cur);
cur_old = cur;
cur = new_instruction();
} else {
/* see if it's a valid label */
if (strlen(buffer) > 0) {
if ((buf = (char *) strtok(buffer, whitespace))) {
instructions++;
if (!inst_root)
inst_root = cur;
if (cur_old)
cur_old->next = cur;
capitalize(buf);
strncpy(cur->mnumonic, buf, MNUMONIC_TXT_LENGTH);
get_operands(cur);
}
// buffer holds untokenized string with charcter at *[0]
if (validate_label(buffer)) {
add_label(buffer, cur);
} else {
do_error_msg(ERR_BADLABEL);
}
}
}
}
/* return either the head or the tail */
return initial_root == NULL ? inst_root : cur;
}
