static void compile_word(int force_macros) {
DICTIONARY_ENTRY *e;
// find it
if(force_macros) {
e=find(FIND_MACRO);
} else {
e=find(FIND_MACRO);
if(!e) e=find(FIND_FORTH);
}
// handle numbers
if(!e) {
dstack_push(parse_number());
execute_cstr(WORD_LITERAL);
} else {
// execute if a macro
if(!force_macros && e->is_macro) {
dstack_push((CELL)e->code_addr);
execute_cstr(WORD_EXECUTE_FORTH);
} else {
dstack_push((CELL)e->code_addr);
execute_cstr(WORD_COMPILE);
}
}
}
static void execute_word(void) {
DICTIONARY_ENTRY *e;
// find it
e=find(FIND_FORTH);
// do it if its there
if(e) {
// handle execute-forth word specially
if(counted_string_equal(e->name, e->name_len,
WORD_EXECUTE_FORTH_RAW, -1)) {
// check dstack
dstack_check();
// jump directly to forth word address
((EXECUTE_FORTH_FUNC)e->code_addr)(&ctx);
// check dstack
dstack_check();
} else {
// call special execute-forth word
dstack_push((CELL)e->code_addr);
execute_cstr(WORD_EXECUTE_FORTH);
}
} else if(execute_built_in(ctx.current_word, ctx.current_word_len)) {
// the above function does what's needed
} else {
dstack_push(parse_number());
}
}
static int execute_built_in(const unsigned char *word, int word_len) {
int i, j;
if(counted_string_equal(word, word_len, "macro", -1)) {
ctx.is_macro=1;
} else if(counted_string_equal(word, word_len, "forth", -1)) {
ctx.is_macro=0;
} else if(counted_string_equal(word, word_len, "unsmudge", -1)) {
ctx.dictionary->smudged=0;
} else if(counted_string_equal(word, word_len, "smudge", -1)) {
ctx.dictionary->smudged=1;
} else if(counted_string_equal(word, word_len, "heap-dump", -1)) {
heap_dump();
} else if(counted_string_equal(word, word_len, "word-dump", -1)) {
word_dump();
} else if(counted_string_equal(word, word_len, "b,", -1)) {
(*ctx.code_here)=dstack_pop();
ctx.code_here++;
} else if(counted_string_equal(word, word_len, "windows?", -1)) {
#ifdef _WIN32
dstack_push(1);
#else
dstack_push(0);
#endif
} else if(counted_string_equal(word, word_len, "load", -1)) {
load(dstack_pop());
} else if(counted_string_equal(word, word_len, "thru", -1)) {
j=dstack_pop();
i=dstack_pop();
for(;i<=j;i++) load(i);
} else {
return 0;
}
return 1;
}
void dstack_test()
{
dstack dst;
dstack_init(&dst, N);
size_t i;
for(i = 0; i < N/2; i++)
dstack_push(&dst, (int)i, DSTACK_L);
for(i = 0; i < N/2; i++)
dstack_push(&dst, (int)i, DSTACK_H);
for(i = 0; i < N/2; i++)
printf("%d\n", dstack_pop(&dst, DSTACK_L));
printf("\n");
for(i = 0; i < N/2; i++)
printf("%d\n", dstack_pop(&dst, DSTACK_H));
dstack_free(&dst);
}
int lang_else(){
data_compile_token(H_BRANCH); //compile branch instruction
U8* newfixup = data_compile_U8(0); //else's fixup address
//fixup if's jump to here...
lang_fixup();
//leave our fixup for if
dstack_push((U32)newfixup);
}
int lang_if(){
data_compile_token(H_0BRANCH); //compile branch instruction
dstack_push((U32)data_compile_U8(0)); //keep fixup on stack
if(!interpret_compuntil("thanx",5)) { //compile until 'then'
printf("lang_if: err \n");
dstack_pop(); //on error, get rid of pfixup
return 0;
}
lang_fixup();
return 1;
}
int lang_begin(){
dstack_push((U32)var->data_ptr); //just save the loop start location
if(!interpret_compuntil("repeat",6)) { //compile until 'again'
printf("lang_begin: err \n");
dstack_pop(); //on error, get rid of pfixup
return 0;
}
data_compile_token(H_BRANCH);
TOKEN* target = (TOKEN*)dstack_pop(); //recover loop start
U32 offset = target - var->data_ptr - 1;
data_compile_U8(offset);
return 1;
}
/*=============================================================================
* times
*
* n times ( )
*
* push n onto return stack
* compile next expression
* compile loop, decrementing RSP count and looping expression.
* pop count off the return stack.
* ==========================================================================*/
int lang_times(){
HINDEX hpush = head_find_abs_or_die("system'core'push");
data_compile_token(hpush);
dstack_push((U32)var->data_ptr); //save loop target on stack
if(interpret_one()) { //compile expression
HINDEX htimes = head_find_abs_or_die("system'core'times");
data_compile_token(htimes);
data_compile_off_S8(dstack_pop());
return 1;
}
return 0;
}
static void lookup_word(void) {
DICTIONARY_ENTRY *e;
// find it
e=find(FIND_FORTH);
if(!e) e=find(FIND_MACRO);
// add to stack if there (or zero on fail)
if(e) {
dstack_push((CELL)e->code_addr);
} else {
ctx.err->is_error=1;
sprintf(ctx.err->message, "unknown word '%s'", ctx.current_word);
}
}
int main(void)
{
struct object obj;
struct object *obp;
const void *vp;
unsigned long num;
unsigned long cmp;
test_assert(dstack_init(&st, STACK_SIZE, sizeof(struct object)));
/* check size is zero */
test_assert(dstack_size(&st) == 0);
test_assert(dstack_SIZE(&st) == 0);
/* check pop on empty is no-op */
test_assert(dstack_pop(&st, (void **) &obp) == 0);
/* check push works */
for (num = 0; num < STACK_SIZE; ++num) {
obj.num = num;
test_assert(dstack_push(&st, &obj));
}
/* check size is correct */
test_assert(dstack_bytes(&st) == STACK_SIZE * sizeof(struct object));
test_assert(dstack_BYTES(&st) == STACK_SIZE * sizeof(struct object));
test_assert(dstack_size(&st) == STACK_SIZE);
test_assert(dstack_SIZE(&st) == STACK_SIZE);
/* check pop and peek work */
for (num = 0; num < STACK_SIZE; ++num) {
dstack_peek(&st, (void **) &obp);
test_assert(obp);
cmp = obp->num;
test_assert(cmp == STACK_SIZE - 1 - num);
dstack_pop(&st, (void **) &obp);
test_assert(obp);
cmp = obp->num;
test_assert(cmp == STACK_SIZE - 1 - num);
}
return 0;
}
int lang_t(){
PTOKEN* p = (PTOKEN*) dstack_pop();
dstack_push( table_dump(p) );
}