void
define_hook(fcode_env_t *env, char *name, int len, char *fcimage)
{
static void (*byteload_ptr)(fcode_env_t *env) = byte_loadfile;
header(env, name, len, 0);
COMPILE_TOKEN(&do_colon);
env->state |= 1;
PUSH(DS, (fstack_t) fcimage);
PUSH(DS, strlen(fcimage));
compile_string(env);
COMPILE_TOKEN(&byteload_ptr);
semi(env);
}
/*
* (is-user-word) ( name-str name-len xt -- )
*/
void
is_user_word(fcode_env_t *env)
{
fstack_t xt;
char *name;
int len;
CHECK_DEPTH(env, 3, "(is-user-word)");
xt = POP(DS);
name = pop_a_string(env, &len);
header(env, name, len, 0);
COMPILE_TOKEN(&do_alias);
COMPILE_TOKEN(xt);
expose_acf(env, name);
}
void
bquote(fcode_env_t *env)
{
char stringbuff[256];
int len, count;
char *strptr;
count = len = next_bytecode(env);
if (env->state) {
COMPILE_TOKEN("e_ptr);
strptr = (char *)HERE;
*strptr++ = len;
while (count--)
*strptr++ = next_bytecode(env);
*strptr++ = 0;
set_here(env, (uchar_t *)strptr, "bquote");
token_roundup(env, "bquote");
} else {
strptr = stringbuff;
while (count--)
*strptr++ = next_bytecode(env);
*strptr = 0;
push_string(env, stringbuff, len);
}
}
void
define_word(fcode_env_t *env, int flag, char *name, void (*fn)(fcode_env_t *))
{
header(env, name, strlen(name), flag);
COMPILE_TOKEN(fn);
expose_acf(env, name);
}
void
bcreate(fcode_env_t *env)
{
env->table[env->last_token].apf = (acf_t)HERE;
show_fcode_def(env, "bcreate");
COMPILE_TOKEN(&do_create);
expose_acf(env, "<bcreate>");
}
void
action_colon(fcode_env_t *env)
{
token_roundup(env, "action_colon");
env->action_ptr[env->action_count] = (token_t)HERE;
COMPILE_TOKEN(&do_colon);
env->action_count++;
env->state |= 1;
}
void
bendcase(fcode_env_t *env)
{
COMPILE_TOKEN(env->table[0x46].apf); /* Hack for now... */
while (TOS) {
bresolve(env);
}
(void) POP(DS);
env->level--;
temporary_execute(env);
}
void
bto(fcode_env_t *env)
{
btick(env);
if (env->state) {
COMPILE_TOKEN(&to_ptr);
} else {
do_set_action(env);
}
}
void
bfield(fcode_env_t *env)
{
env->table[env->last_token].apf = (acf_t)HERE;
show_fcode_def(env, "bfield");
COMPILE_TOKEN(&do_field);
over(env);
compile_comma(env);
add(env);
expose_acf(env, "<bfield>");
}
void
bcolon(fcode_env_t *env)
{
if (env->state == 0) {
env->table[env->last_token].apf = (acf_t)HERE;
env->table[env->last_token].flags = 0;
show_fcode_def(env, "bcolon");
}
env->state |= 1;
COMPILE_TOKEN(&do_colon);
}
void
do_code(fcode_env_t *env, int token, char *name, void (*fn)(fcode_env_t *))
{
env->table[token].name = name;
if (fn == NULL) {
env->table[token].apf = NULL;
env->table[token].name = name;
} else {
header(env, name, strlen(name), 0);
env->table[token].apf = (acf_t)HERE;
COMPILE_TOKEN(fn);
expose_acf(env, name);
}
}
void
define_actions(fcode_env_t *env, int n, token_t *array)
{
int a;
PUSH(DS, (fstack_t)n);
actions(env);
a = 0;
while (n--) {
action_colon(env);
COMPILE_TOKEN(&array[a]);
env->state |= 8;
semi(env);
a++;
}
}
void
branch_common(fcode_env_t *env, short direction, fstack_t which, int doswap)
{
fstack_t *sp;
token_t *branch_loc;
ASSERT((which < 3) && (which >= 0));
which = (fstack_t)&bbranch_ptrs[which];
set_temporary_compile(env);
COMPILE_TOKEN(which);
if (direction >= 0) {
bmark(env);
if (doswap)
swap(env);
PUSH(DS, 0);
compile_comma(env);
} else {
/*
* We look down the stack for a branch location
* that isn't pointing to zero (i.e. a forward branch label).
* We move the first one we find to the top of the stack,
* which is what gets compiled in with 'compile_comma'.
* Not finding a valid branch label is bad.
*/
for (sp = env->ds; sp >= env->ds0; sp--) {
branch_loc = (token_t *)*sp;
if (branch_loc && *branch_loc) {
break;
}
}
if (sp < env->ds0)
log_message(MSG_ERROR, "branch_common: back: "
"no branch loc on stack\n");
else {
/* Move branch_loc to top of data stack */
for (; sp < env->ds; sp++)
*sp = sp[1];
*sp = (fstack_t)branch_loc;
}
env->level--;
compile_comma(env);
temporary_execute(env);
}
}
