efcode/engine/forth.c

	forth.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/*
 * CDDL HEADER START
 *
 * The contents of this file are subject to the terms of the
 * Common Development and Distribution License, Version 1.0 only
 * (the "License").  You may not use this file except in compliance
 * with the License.
 *
 * You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
 * or http://www.opensolaris.org/os/licensing.
 * See the License for the specific language governing permissions
 * and limitations under the License.
 *
 * When distributing Covered Code, include this CDDL HEADER in each
 * file and include the License file at usr/src/OPENSOLARIS.LICENSE.
 * If applicable, add the following below this CDDL HEADER, with the
 * fields enclosed by brackets "[]" replaced with your own identifying
 * information: Portions Copyright [yyyy] [name of copyright owner]
 *
 * CDDL HEADER END
 */
/*
 * Copyright (c) 2000 by Sun Microsystems, Inc.
 * All rights reserved.
 */

#pragma ident   "%Z%%M% %I% %E% SMI"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>

#include <fcode/private.h>
#include <fcode/log.h>

void (*semi_ptr)(fcode_env_t *env) = do_semi;
void (*does_ptr)(fcode_env_t *env) = install_does;
void (*quote_ptr)(fcode_env_t *env) = do_quote;
void (*blit_ptr)(fcode_env_t *env) = do_literal;
void (*tlit_ptr)(fcode_env_t *env) = do_literal;
void (*do_bdo_ptr)(fcode_env_t *env) = do_bdo;
void (*do_bqdo_ptr)(fcode_env_t *env) = do_bqdo;
void (*create_ptr)(fcode_env_t *env) = do_creator;
void (*do_leave_ptr)(fcode_env_t *env) = do_bleave;
void (*do_loop_ptr)(fcode_env_t *env) = do_bloop;
void (*do_ploop_ptr)(fcode_env_t *env) = do_bploop;

void unaligned_lstore(fcode_env_t *);
void unaligned_wstore(fcode_env_t *);
void unaligned_lfetch(fcode_env_t *);
void unaligned_wfetch(fcode_env_t *);

/* start with the simple maths functions */


void
add(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "+");
    d = POP(DS);
    TOS += d;
}

void
subtract(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "-");
    d = POP(DS);
    TOS -= d;
}

void
multiply(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "*");
    d = POP(DS);
    TOS *= d;
}

void
slash_mod(fcode_env_t *env)
{
    fstack_t d, o, t, rem;
    int sign = 1;

    CHECK_DEPTH(env, 2, "/mod");
    d = POP(DS);
    o = t = POP(DS);

    if (d == 0) {
        throw_from_fclib(env, 1, "/mod divide by zero");
    }
    sign = ((d ^ t) < 0);
    if (d < 0) {
        d = -d;
        if (sign) {
            t += (d-1);
        }
    }
    if (t < 0) {
        if (sign) {
            t -= (d-1);
        }
        t = -t;
    }
    t = t / d;
    if ((o ^ sign) < 0) {
        rem = (t * d) + o;
    } else {
        rem = o - (t*d);
    }
    if (sign) {
        t = -t;
    }
    PUSH(DS, rem);
    PUSH(DS, t);
}

/*
 * 'u/mod' Fcode implementation.
 */
void
uslash_mod(fcode_env_t *env)
{
    u_lforth_t u1, u2;

    CHECK_DEPTH(env, 2, "u/mod");
    u2 = POP(DS);
    u1 = POP(DS);

    if (u2 == 0)
        forth_abort(env, "u/mod: divide by zero");
    PUSH(DS, u1 % u2);
    PUSH(DS, u1 / u2);
}

void
divide(fcode_env_t *env)
{
    CHECK_DEPTH(env, 2, "/");
    slash_mod(env);
    nip(env);
}

void
mod(fcode_env_t *env)
{
    CHECK_DEPTH(env, 2, "mod");
    slash_mod(env);
    drop(env);
}

void
and(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "and");
    d = POP(DS);
    TOS &= d;
}

void
or(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "or");
    d = POP(DS);
    TOS |= d;
}

void
xor(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "xor");
    d = POP(DS);
    TOS ^= d;
}

void
invert(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "invert");
    TOS = ~TOS;
}

void
lshift(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "lshift");
    d = POP(DS);
    TOS = TOS << d;
}

void
rshift(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "rshift");
    d = POP(DS);
    TOS = ((ufstack_t)TOS) >> d;
}

void
rshifta(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, ">>a");
    d = POP(DS);
    TOS = ((s_lforth_t)TOS) >> d;
}

void
negate(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "negate");
    TOS = -TOS;
}

void
f_abs(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "abs");
    if (TOS < 0) TOS = -TOS;
}

void
f_min(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "min");
    d = POP(DS);
    if (d < TOS)    TOS = d;
}

void
f_max(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "max");
    d = POP(DS);
    if (d > TOS)    TOS = d;
}

void
to_r(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, ">r");
    PUSH(RS, POP(DS));
}

void
from_r(fcode_env_t *env)
{
    CHECK_RETURN_DEPTH(env, 1, "r>");
    PUSH(DS, POP(RS));
}

void
rfetch(fcode_env_t *env)
{
    CHECK_RETURN_DEPTH(env, 1, "r@");
    PUSH(DS, *RS);
}

void
f_exit(fcode_env_t *env)
{
    CHECK_RETURN_DEPTH(env, 1, "exit");
    IP = (token_t *)POP(RS);
}

#define COMPARE(cmp, rhs)   ((((s_lforth_t)TOS) cmp((s_lforth_t)(rhs))) ? \
                    TRUE : FALSE)
#define UCOMPARE(cmp, rhs)  ((((u_lforth_t)TOS) cmp((u_lforth_t)(rhs))) ? \
                    TRUE : FALSE)
#define EQUALS      ==
#define NOTEQUALS   !=
#define LESSTHAN    <
#define LESSEQUALS  <=
#define GREATERTHAN >
#define GREATEREQUALS   >=

void
zero_equals(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "0=");
    TOS = COMPARE(EQUALS, 0);
}

void
zero_not_equals(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "0<>");
    TOS = COMPARE(NOTEQUALS, 0);
}

void
zero_less(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "0<");
    TOS = COMPARE(LESSTHAN, 0);
}

void
zero_less_equals(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "0<=");
    TOS = COMPARE(LESSEQUALS, 0);
}

void
zero_greater(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "0>");
    TOS = COMPARE(GREATERTHAN, 0);
}

void
zero_greater_equals(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "0>=");
    TOS = COMPARE(GREATEREQUALS, 0);
}

void
less(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "<");
    d = POP(DS);
    TOS = COMPARE(LESSTHAN, d);
}

void
greater(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, ">");
    d = POP(DS);
    TOS = COMPARE(GREATERTHAN, d);
}

void
equals(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "=");
    d = POP(DS);
    TOS = COMPARE(EQUALS, d);
}

void
not_equals(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "<>");
    d = POP(DS);
    TOS = COMPARE(NOTEQUALS, d);
}


void
unsign_greater(fcode_env_t *env)
{
    ufstack_t d;

    CHECK_DEPTH(env, 2, "u>");
    d = POP(DS);
    TOS = UCOMPARE(GREATERTHAN, d);
}

void
unsign_less_equals(fcode_env_t *env)
{
    ufstack_t d;

    CHECK_DEPTH(env, 2, "u<=");
    d = POP(DS);
    TOS = UCOMPARE(LESSEQUALS, d);
}

void
unsign_less(fcode_env_t *env)
{
    ufstack_t d;

    CHECK_DEPTH(env, 2, "u<");
    d = POP(DS);
    TOS = UCOMPARE(LESSTHAN, d);
}

void
unsign_greater_equals(fcode_env_t *env)
{
    ufstack_t d;

    CHECK_DEPTH(env, 2, "u>=");
    d = POP(DS);
    TOS = UCOMPARE(GREATEREQUALS, d);
}

void
greater_equals(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, ">=");
    d = POP(DS);
    TOS = COMPARE(GREATEREQUALS, d);
}

void
less_equals(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "<=");
    d = POP(DS);
    TOS = COMPARE(LESSEQUALS, d);
}

void
between(fcode_env_t *env)
{
    s_lforth_t hi, lo;

    CHECK_DEPTH(env, 3, "between");
    hi = (s_lforth_t)POP(DS);
    lo = (s_lforth_t)POP(DS);
    TOS = (((s_lforth_t)TOS >= lo) && ((s_lforth_t)TOS <= hi) ? -1 : 0);
}

void
within(fcode_env_t *env)
{
    s_lforth_t lo, hi;

    CHECK_DEPTH(env, 3, "within");
    hi = (s_lforth_t)POP(DS);
    lo = (s_lforth_t)POP(DS);
    TOS = ((((s_lforth_t)TOS >= lo) && ((s_lforth_t)TOS < hi)) ? -1 : 0);
}

void
do_literal(fcode_env_t *env)
{
    PUSH(DS, *IP);
    IP++;
}

void
literal(fcode_env_t *env)
{
    if (env->state) {
        COMPILE_TOKEN(&blit_ptr);
        compile_comma(env);
    }
}

void
do_also(fcode_env_t *env)
{
    token_t *d = *ORDER;

    if (env->order_depth < (MAX_ORDER - 1)) {
        env->order[++env->order_depth] = d;
        debug_msg(DEBUG_CONTEXT, "CONTEXT:also: %d/%p/%p\n",
            env->order_depth, CONTEXT, env->current);
    } else
        log_message(MSG_WARN, "Vocabulary search order exceeds: %d\n",
            MAX_ORDER);
}

void
do_previous(fcode_env_t *env)
{
    if (env->order_depth) {
        env->order_depth--;
        debug_msg(DEBUG_CONTEXT, "CONTEXT:previous: %d/%p/%p\n",
            env->order_depth, CONTEXT, env->current);
    }
}

#ifdef DEBUG
void
do_order(fcode_env_t *env)
{
    int i;

    log_message(MSG_INFO, "Order: Depth: %ld: ", env->order_depth);
    for (i = env->order_depth; i >= 0 && env->order[i]; i--)
        log_message(MSG_INFO, "%p ", (void *)env->order[i]);
    log_message(MSG_INFO, "\n");
}
#endif

void
noop(fcode_env_t *env)
{
    /* what a waste of cycles */
}


#define FW_PER_FL   (sizeof (lforth_t)/sizeof (wforth_t))

void
lwsplit(fcode_env_t *env)
{
    union {
        u_wforth_t l_wf[FW_PER_FL];
        u_lforth_t l_lf;
    } d;
    int i;

    CHECK_DEPTH(env, 1, "lwsplit");
    d.l_lf = POP(DS);
    for (i = 0; i < FW_PER_FL; i++)
        PUSH(DS, d.l_wf[(FW_PER_FL - 1) - i]);
}

void
wljoin(fcode_env_t *env)
{
    union {
        u_wforth_t l_wf[FW_PER_FL];
        u_lforth_t l_lf;
    } d;
    int i;

    CHECK_DEPTH(env, FW_PER_FL, "wljoin");
    for (i = 0; i < FW_PER_FL; i++)
        d.l_wf[i] = POP(DS);
    PUSH(DS, d.l_lf);
}

void
lwflip(fcode_env_t *env)
{
    union {
        u_wforth_t l_wf[FW_PER_FL];
        u_lforth_t l_lf;
    } d, c;
    int i;

    CHECK_DEPTH(env, 1, "lwflip");
    d.l_lf = POP(DS);
    for (i = 0; i < FW_PER_FL; i++)
        c.l_wf[i] = d.l_wf[(FW_PER_FL - 1) - i];
    PUSH(DS, c.l_lf);
}

void
lbsplit(fcode_env_t *env)
{
    union {
        uchar_t l_bytes[sizeof (lforth_t)];
        u_lforth_t l_lf;
    } d;
    int i;

    CHECK_DEPTH(env, 1, "lbsplit");
    d.l_lf = POP(DS);
    for (i = 0; i < sizeof (lforth_t); i++)
        PUSH(DS, d.l_bytes[(sizeof (lforth_t) - 1) - i]);
}

void
bljoin(fcode_env_t *env)
{
    union {
        uchar_t l_bytes[sizeof (lforth_t)];
        u_lforth_t l_lf;
    } d;
    int i;

    CHECK_DEPTH(env, sizeof (lforth_t), "bljoin");
    for (i = 0; i < sizeof (lforth_t); i++)
        d.l_bytes[i] = POP(DS);
    PUSH(DS, (fstack_t)d.l_lf);
}

void
lbflip(fcode_env_t *env)
{
    union {
        uchar_t l_bytes[sizeof (lforth_t)];
        u_lforth_t l_lf;
    } d, c;
    int i;

    CHECK_DEPTH(env, 1, "lbflip");
    d.l_lf = POP(DS);
    for (i = 0; i < sizeof (lforth_t); i++)
        c.l_bytes[i] = d.l_bytes[(sizeof (lforth_t) - 1) - i];
    PUSH(DS, c.l_lf);
}

void
wbsplit(fcode_env_t *env)
{
    union {
        uchar_t w_bytes[sizeof (wforth_t)];
        u_wforth_t w_wf;
    } d;
    int i;

    CHECK_DEPTH(env, 1, "wbsplit");
    d.w_wf = POP(DS);
    for (i = 0; i < sizeof (wforth_t); i++)
        PUSH(DS, d.w_bytes[(sizeof (wforth_t) - 1) - i]);
}

void
bwjoin(fcode_env_t *env)
{
    union {
        uchar_t w_bytes[sizeof (wforth_t)];
        u_wforth_t w_wf;
    } d;
    int i;

    CHECK_DEPTH(env, sizeof (wforth_t), "bwjoin");
    for (i = 0; i < sizeof (wforth_t); i++)
        d.w_bytes[i] = POP(DS);
    PUSH(DS, d.w_wf);
}

void
wbflip(fcode_env_t *env)
{
    union {
        uchar_t w_bytes[sizeof (wforth_t)];
        u_wforth_t w_wf;
    } c, d;
    int i;

    CHECK_DEPTH(env, 1, "wbflip");
    d.w_wf = POP(DS);
    for (i = 0; i < sizeof (wforth_t); i++)
        c.w_bytes[i] = d.w_bytes[(sizeof (wforth_t) - 1) - i];
    PUSH(DS, c.w_wf);
}

void
upper_case(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "upc");
    TOS = toupper(TOS);
}

void
lower_case(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "lcc");
    TOS = tolower(TOS);
}

void
pack_str(fcode_env_t *env)
{
    char *buf;
    size_t len;
    char *str;

    CHECK_DEPTH(env, 3, "pack");
    buf = (char *)POP(DS);
    len = (size_t)POP(DS);
    str = (char *)TOS;
    TOS = (fstack_t)buf;
    *buf++ = (uchar_t)len;
    strncpy(buf, str, (len&0xff));
}

void
count_str(fcode_env_t *env)
{
    uchar_t *len;

    CHECK_DEPTH(env, 1, "count");
    len = (uchar_t *)TOS;
    TOS += 1;
    PUSH(DS, *len);
}

void
to_body(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, ">body");
    TOS = (fstack_t)(((acf_t)TOS)+1);
}

void
to_acf(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "body>");
    TOS = (fstack_t)(((acf_t)TOS)-1);
}

/*
 * 'unloop' Fcode implementation, drop 3 loop ctrl elements off return stack.
 */
static void
unloop(fcode_env_t *env)
{
    CHECK_RETURN_DEPTH(env, 3, "unloop");
    RS -= 3;
}

/*
 * 'um*' Fcode implementation.
 */
static void
um_multiply(fcode_env_t *env)
{
    ufstack_t u1, u2;
    dforth_t d;

    CHECK_DEPTH(env, 2, "um*");
    u1 = POP(DS);
    u2 = POP(DS);
    d = u1 * u2;
    push_double(env, d);
}

/*
 * um/mod (d.lo d.hi u -- urem uquot)
 */
static void
um_slash_mod(fcode_env_t *env)
{
    u_dforth_t d;
    uint32_t u, urem, uquot;

    CHECK_DEPTH(env, 3, "um/mod");
    u = (uint32_t)POP(DS);
    d = pop_double(env);
    urem = d % u;
    uquot = d / u;
    PUSH(DS, urem);
    PUSH(DS, uquot);
}

/*
 * d+ (d1.lo d1.hi d2.lo d2.hi -- dsum.lo dsum.hi)
 */
static void
d_plus(fcode_env_t *env)
{
    dforth_t d1, d2;

    CHECK_DEPTH(env, 4, "d+");
    d2 = pop_double(env);
    d1 = pop_double(env);
    d1 += d2;
    push_double(env, d1);
}

/*
 * d- (d1.lo d1.hi d2.lo d2.hi -- ddif.lo ddif.hi)
 */
static void
d_minus(fcode_env_t *env)
{
    dforth_t d1, d2;

    CHECK_DEPTH(env, 4, "d-");
    d2 = pop_double(env);
    d1 = pop_double(env);
    d1 -= d2;
    push_double(env, d1);
}

void
set_here(fcode_env_t *env, uchar_t *new_here, char *where)
{
    if (new_here < HERE) {
        if (strcmp(where, "temporary_execute")) {
            /*
             * Other than temporary_execute, no one should set
             * here backwards.
             */
            log_message(MSG_WARN, "Warning: set_here(%s) back: old:"
                " %p new: %p\n", where, HERE, new_here);
        }
    }
    if (new_here >= env->base + dict_size)
        forth_abort(env, "Here (%p) set past dictionary end (%p)",
            new_here, env->base + dict_size);
    HERE = new_here;
}

static void
unaligned_store(fcode_env_t *env)
{
    extern void unaligned_xstore(fcode_env_t *);

    if (sizeof (fstack_t) == sizeof (lforth_t))
        unaligned_lstore(env);
    else
        unaligned_xstore(env);
}

static void
unaligned_fetch(fcode_env_t *env)
{
    extern void unaligned_xfetch(fcode_env_t *);

    if (sizeof (fstack_t) == sizeof (lforth_t))
        unaligned_lfetch(env);
    else
        unaligned_xfetch(env);
}

void
comma(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, ",");
    DEBUGF(COMMA, dump_comma(env, ","));
    PUSH(DS, (fstack_t)HERE);
    unaligned_store(env);
    set_here(env, HERE + sizeof (fstack_t), "comma");
}

void
lcomma(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "l,");
    DEBUGF(COMMA, dump_comma(env, "l,"));
    PUSH(DS, (fstack_t)HERE);
    unaligned_lstore(env);
    set_here(env, HERE + sizeof (u_lforth_t), "lcomma");
}

void
wcomma(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "w,");
    DEBUGF(COMMA, dump_comma(env, "w,"));
    PUSH(DS, (fstack_t)HERE);
    unaligned_wstore(env);
    set_here(env, HERE + sizeof (u_wforth_t), "wcomma");
}

void
ccomma(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "c,");
    DEBUGF(COMMA, dump_comma(env, "c,"));
    PUSH(DS, (fstack_t)HERE);
    cstore(env);
    set_here(env, HERE + sizeof (uchar_t), "ccomma");
}

void
token_roundup(fcode_env_t *env, char *where)
{
    if ((((token_t)HERE) & (sizeof (token_t) - 1)) != 0) {
        set_here(env, (uchar_t *)TOKEN_ROUNDUP(HERE), where);
    }
}

void
compile_comma(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "compile,");
    DEBUGF(COMMA, dump_comma(env, "compile,"));
    token_roundup(env, "compile,");
    PUSH(DS, (fstack_t)HERE);
    unaligned_store(env);
    set_here(env, HERE + sizeof (fstack_t), "compile,");
}

void
unaligned_lfetch(fcode_env_t *env)
{
    fstack_t addr;
    int i;

    CHECK_DEPTH(env, 1, "unaligned-l@");
    addr = POP(DS);
    for (i = 0; i < sizeof (lforth_t); i++, addr++) {
        PUSH(DS, addr);
        cfetch(env);
    }
    bljoin(env);
    lbflip(env);
}

void
unaligned_lstore(fcode_env_t *env)
{
    fstack_t addr;
    int i;

    CHECK_DEPTH(env, 2, "unaligned-l!");
    addr = POP(DS);
    lbsplit(env);
    for (i = 0; i < sizeof (lforth_t); i++, addr++) {
        PUSH(DS, addr);
        cstore(env);
    }
}

void
unaligned_wfetch(fcode_env_t *env)
{
    fstack_t addr;
    int i;

    CHECK_DEPTH(env, 1, "unaligned-w@");
    addr = POP(DS);
    for (i = 0; i < sizeof (wforth_t); i++, addr++) {
        PUSH(DS, addr);
        cfetch(env);
    }
    bwjoin(env);
    wbflip(env);
}

void
unaligned_wstore(fcode_env_t *env)
{
    fstack_t addr;
    int i;

    CHECK_DEPTH(env, 2, "unaligned-w!");
    addr = POP(DS);
    wbsplit(env);
    for (i = 0; i < sizeof (wforth_t); i++, addr++) {
        PUSH(DS, addr);
        cstore(env);
    }
}

/*
 * 'lbflips' Fcode implementation.
 */
static void
lbflips(fcode_env_t *env)
{
    fstack_t len, addr;
    int i;

    CHECK_DEPTH(env, 2, "lbflips");
    len = POP(DS);
    addr = POP(DS);
    for (i = 0; i < len; i += sizeof (lforth_t),
        addr += sizeof (lforth_t)) {
        PUSH(DS, addr);
        unaligned_lfetch(env);
        lbflip(env);
        PUSH(DS, addr);
        unaligned_lstore(env);
    }
}

/*
 * 'wbflips' Fcode implementation.
 */
static void
wbflips(fcode_env_t *env)
{
    fstack_t len, addr;
    int i;

    CHECK_DEPTH(env, 2, "wbflips");
    len = POP(DS);
    addr = POP(DS);
    for (i = 0; i < len; i += sizeof (wforth_t),
        addr += sizeof (wforth_t)) {
        PUSH(DS, addr);
        unaligned_wfetch(env);
        wbflip(env);
        PUSH(DS, addr);
        unaligned_wstore(env);
    }
}

/*
 * 'lwflips' Fcode implementation.
 */
static void
lwflips(fcode_env_t *env)
{
    fstack_t len, addr;
    int i;

    CHECK_DEPTH(env, 2, "lwflips");
    len = POP(DS);
    addr = POP(DS);
    for (i = 0; i < len; i += sizeof (lforth_t),
        addr += sizeof (lforth_t)) {
        PUSH(DS, addr);
        unaligned_lfetch(env);
        lwflip(env);
        PUSH(DS, addr);
        unaligned_lstore(env);
    }
}

void
base(fcode_env_t *env)
{
    PUSH(DS, (fstack_t)&env->num_base);
}

void
dot_s(fcode_env_t *env)
{
    output_data_stack(env, MSG_INFO);
}

void
state(fcode_env_t *env)
{
    PUSH(DS, (fstack_t)&env->state);
}

int
is_digit(char digit, int num_base, fstack_t *dptr)
{
    int error = 0;
    char base;

    if (num_base < 10) {
        base = '0' + (num_base-1);
    } else {
        base = 'a' + (num_base - 10);
    }

    *dptr = 0;
    if (digit > '9') digit |= 0x20;
    if (((digit < '0') || (digit > base)) ||
        ((digit > '9') && (digit < 'a') && (num_base > 10)))
        error = 1;
    else {
        if (digit <= '9')
            digit -= '0';
        else
            digit = digit - 'a' + 10;
        *dptr = digit;
    }
    return (error);
}

void
dollar_number(fcode_env_t *env)
{
    char *buf;
    fstack_t value;
    int len, sign = 1, error = 0;

    CHECK_DEPTH(env, 2, "$number");
    buf = pop_a_string(env, &len);
    if (*buf == '-') {
        sign = -1;
        buf++;
        len--;
    }
    value = 0;
    while (len-- && !error) {
        fstack_t digit;

        if (*buf == '.') {
            buf++;
            continue;
        }
        value *= env->num_base;
        error = is_digit(*buf++, env->num_base, &digit);
        value += digit;
    }
    if (error) {
        PUSH(DS, -1);
    } else {
        value *= sign;
        PUSH(DS, value);
        PUSH(DS, 0);
    }
}

void
digit(fcode_env_t *env)
{
    fstack_t base;
    fstack_t value;

    CHECK_DEPTH(env, 2, "digit");
    base = POP(DS);
    if (is_digit(TOS, base, &value))
        PUSH(DS, 0);
    else {
        TOS = value;
        PUSH(DS, -1);
    }
}

void
space(fcode_env_t *env)
{
    PUSH(DS, ' ');
}

void
backspace(fcode_env_t *env)
{
    PUSH(DS, '\b');
}

void
bell(fcode_env_t *env)
{
    PUSH(DS, '\a');
}

void
fc_bounds(fcode_env_t *env)
{
    fstack_t lo, hi;

    CHECK_DEPTH(env, 2, "bounds");
    lo = DS[-1];
    hi = TOS;
    DS[-1] = lo+hi;
    TOS = lo;
}

void
here(fcode_env_t *env)
{
    PUSH(DS, (fstack_t)HERE);
}

void
aligned(fcode_env_t *env)
{
    ufstack_t a;

    CHECK_DEPTH(env, 1, "aligned");
    a = (TOS & (sizeof (lforth_t) - 1));
    if (a)
        TOS += (sizeof (lforth_t) - a);
}

void
instance(fcode_env_t *env)
{
    env->instance_mode |= 1;
}

void
semi(fcode_env_t *env)
{

    env->state &= ~1;
    COMPILE_TOKEN(&semi_ptr);

    /*
     * check if we need to supress expose action;
     * If so this is an internal word and has no link field
     * or it is a temporary compile
     */

    if (env->state == 0) {
        expose_acf(env, "<semi>");
    }
    if (env->state & 8) {
        env->state ^= 8;
    }
}

void
do_create(fcode_env_t *env)
{
    PUSH(DS, (fstack_t)WA);
}

void
drop(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "drop");
    (void) POP(DS);
}

void
f_dup(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 1, "dup");
    d = TOS;
    PUSH(DS, d);
}

void
over(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "over");
    d = DS[-1];
    PUSH(DS, d);
}

void
swap(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "swap");
    d = DS[-1];
    DS[-1] = DS[0];
    DS[0]  = d;
}


void
rot(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 3, "rot");
    d = DS[-2];
    DS[-2] = DS[-1];
    DS[-1] = TOS;
    TOS    = d;
}

void
minus_rot(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 3, "-rot");
    d = TOS;
    TOS    = DS[-1];
    DS[-1] = DS[-2];
    DS[-2] = d;
}

void
tuck(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "tuck");
    d = TOS;
    swap(env);
    PUSH(DS, d);
}

void
nip(fcode_env_t *env)
{
    CHECK_DEPTH(env, 2, "nip");
    swap(env);
    drop(env);
}

void
qdup(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 1, "?dup");
    d = TOS;
    if (d)
        PUSH(DS, d);
}

void
depth(fcode_env_t *env)
{
    fstack_t d;

    d =  DS - env->ds0;
    PUSH(DS, d);
}

void
pick(fcode_env_t *env)
{
    fstack_t p;

    CHECK_DEPTH(env, 1, "pick");
    p = POP(DS);
    if (p < 0 || p >= (env->ds - env->ds0))
        forth_abort(env, "pick: invalid pick value: %d\n", (int)p);
    p = DS[-p];
    PUSH(DS, p);
}

void
roll(fcode_env_t *env)
{
    fstack_t d, r;

    CHECK_DEPTH(env, 1, "roll");
    r = POP(DS);
    if (r <= 0 || r >= (env->ds - env->ds0))
        forth_abort(env, "roll: invalid roll value: %d\n", (int)r);

    d = DS[-r];
    while (r) {
        DS[-r] = DS[ -(r-1) ];
        r--;
    }
    TOS = d;
}

void
two_drop(fcode_env_t *env)
{
    CHECK_DEPTH(env, 2, "2drop");
    DS -= 2;
}

void
two_dup(fcode_env_t *env)
{
    CHECK_DEPTH(env, 2, "2dup");
    DS[1] = DS[-1];
    DS[2] = TOS;
    DS += 2;
}

void
two_over(fcode_env_t *env)
{
    fstack_t a, b;

    CHECK_DEPTH(env, 4, "2over");
    a = DS[-3];
    b = DS[-2];
    PUSH(DS, a);
    PUSH(DS, b);
}

void
two_swap(fcode_env_t *env)
{
    fstack_t a, b;

    CHECK_DEPTH(env, 4, "2swap");
    a = DS[-3];
    b = DS[-2];
    DS[-3] = DS[-1];
    DS[-2] = TOS;
    DS[-1] = a;
    TOS    = b;
}

void
two_rot(fcode_env_t *env)
{
    fstack_t a, b;

    CHECK_DEPTH(env, 6, "2rot");
    a = DS[-5];
    b = DS[-4];
    DS[-5] = DS[-3];
    DS[-4] = DS[-2];
    DS[-3] = DS[-1];
    DS[-2] = TOS;
    DS[-1] = a;
    TOS    = b;
}

void
two_slash(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "2/");
    TOS = TOS >> 1;
}

void
utwo_slash(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "u2/");
    TOS = (ufstack_t)((ufstack_t)TOS) >> 1;
}

void
two_times(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "2*");
    TOS = (ufstack_t)((ufstack_t)TOS) << 1;
}

void
slash_c(fcode_env_t *env)
{
    PUSH(DS, sizeof (char));
}

void
slash_w(fcode_env_t *env)
{
    PUSH(DS, sizeof (wforth_t));
}

void
slash_l(fcode_env_t *env)
{
    PUSH(DS, sizeof (lforth_t));
}

void
slash_n(fcode_env_t *env)
{
    PUSH(DS, sizeof (fstack_t));
}

void
ca_plus(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "ca+");
    d = POP(DS);
    TOS += d * sizeof (char);
}

void
wa_plus(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "wa+");
    d = POP(DS);
    TOS += d * sizeof (wforth_t);
}

void
la_plus(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "la+");
    d = POP(DS);
    TOS += d * sizeof (lforth_t);
}

void
na_plus(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "na+");
    d = POP(DS);
    TOS += d * sizeof (fstack_t);
}

void
char_plus(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "char+");
    TOS += sizeof (char);
}

void
wa1_plus(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "wa1+");
    TOS += sizeof (wforth_t);
}

void
la1_plus(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "la1+");
    TOS += sizeof (lforth_t);
}

void
cell_plus(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "cell+");
    TOS += sizeof (fstack_t);
}

void
do_chars(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "chars");
}

void
slash_w_times(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "/w*");
    TOS *= sizeof (wforth_t);
}

void
slash_l_times(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "/l*");
    TOS *= sizeof (lforth_t);
}

void
cells(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "cells");
    TOS *= sizeof (fstack_t);
}

void
do_on(fcode_env_t *env)
{
    variable_t *d;

    CHECK_DEPTH(env, 1, "on");
    d = (variable_t *)POP(DS);
    *d = -1;
}

void
do_off(fcode_env_t *env)
{
    variable_t *d;

    CHECK_DEPTH(env, 1, "off");
    d = (variable_t *)POP(DS);
    *d = 0;
}

void
fetch(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "@");
    TOS = *((variable_t *)TOS);
}

void
lfetch(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "l@");
    TOS = *((lforth_t *)TOS);
}

void
wfetch(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "w@");
    TOS = *((wforth_t *)TOS);
}

void
swfetch(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "<w@");
    TOS = *((s_wforth_t *)TOS);
}

void
cfetch(fcode_env_t *env)
{
    CHECK_DEPTH(env, 1, "c@");
    TOS = *((uchar_t *)TOS);
}

void
store(fcode_env_t *env)
{
    variable_t *dptr;

    CHECK_DEPTH(env, 2, "!");
    dptr = (variable_t *)POP(DS);
    *dptr = POP(DS);
}

void
addstore(fcode_env_t *env)
{
    variable_t *dptr;

    CHECK_DEPTH(env, 2, "+!");
    dptr = (variable_t *)POP(DS);
    *dptr = POP(DS) + *dptr;
}

void
lstore(fcode_env_t *env)
{
    lforth_t *dptr;

    CHECK_DEPTH(env, 2, "l!");
    dptr = (lforth_t *)POP(DS);
    *dptr = (lforth_t)POP(DS);
}

void
wstore(fcode_env_t *env)
{
    wforth_t *dptr;

    CHECK_DEPTH(env, 2, "w!");
    dptr = (wforth_t *)POP(DS);
    *dptr = (wforth_t)POP(DS);
}

void
cstore(fcode_env_t *env)
{
    uchar_t *dptr;

    CHECK_DEPTH(env, 2, "c!");
    dptr = (uchar_t *)POP(DS);
    *dptr = (uchar_t)POP(DS);
}

void
two_fetch(fcode_env_t *env)
{
    variable_t *d;

    CHECK_DEPTH(env, 1, "2@");
    d = (variable_t *)POP(DS);
    PUSH(DS, (fstack_t)(d + 1));
    unaligned_fetch(env);
    PUSH(DS, (fstack_t)d);
    unaligned_fetch(env);
}

void
two_store(fcode_env_t *env)
{
    variable_t *d;

    CHECK_DEPTH(env, 3, "2!");
    d = (variable_t *)POP(DS);
    PUSH(DS, (fstack_t)d);
    unaligned_store(env);
    PUSH(DS, (fstack_t)(d + 1));
    unaligned_store(env);
}

/*
 * 'move' Fcode reimplemented in fcdriver to check for mapped addresses.
 */
void
fc_move(fcode_env_t *env)
{
    void *dest, *src;
    size_t len;

    CHECK_DEPTH(env, 3, "move");
    len  = (size_t)POP(DS);
    dest = (void *)POP(DS);
    src  = (void *)POP(DS);

    memmove(dest, src, len);
}

void
fc_fill(fcode_env_t *env)
{
    void *dest;
    uchar_t val;
    size_t len;

    CHECK_DEPTH(env, 3, "fill");
    val  = (uchar_t)POP(DS);
    len  = (size_t)POP(DS);
    dest = (void *)POP(DS);
    memset(dest, val, len);
}

void
fc_comp(fcode_env_t *env)
{
    char *str1, *str2;
    size_t len;
    int res;

    CHECK_DEPTH(env, 3, "comp");
    len  = (size_t)POP(DS);
    str1 = (char *)POP(DS);
    str2 = (char *)POP(DS);
    res  = memcmp(str2, str1, len);
    if (res > 0)
        res = 1;
    else if (res < 0)
        res = -1;
    PUSH(DS, res);
}

void
set_temporary_compile(fcode_env_t *env)
{
    if (!env->state) {
        token_roundup(env, "set_temporary_compile");
        PUSH(RS, (fstack_t)HERE);
        env->state = 3;
        COMPILE_TOKEN(&do_colon);
    }
}

void
bmark(fcode_env_t *env)
{
    set_temporary_compile(env);
    env->level++;
    PUSH(DS, (fstack_t)HERE);
}

void
temporary_execute(fcode_env_t *env)
{
    uchar_t *saved_here;

    if ((env->level == 0) && (env->state & 2)) {
        fstack_t d = POP(RS);

        semi(env);

        saved_here = HERE;
        /* execute the temporary definition */
        env->state &= ~2;
        PUSH(DS, d);
        execute(env);

        /* now wind the dictionary back! */
        if (saved_here != HERE) {
            debug_msg(DEBUG_COMMA, "Ignoring set_here in"
                " temporary_execute\n");
        } else
            set_here(env, (uchar_t *)d, "temporary_execute");
    }
}

void
bresolve(fcode_env_t *env)
{
    token_t *prev = (token_t *)POP(DS);

    env->level--;
    *prev = (token_t)HERE;
    temporary_execute(env);
}

#define BRANCH_IP(ipp)  ((token_t *)(*((token_t *)(ipp))))

void
do_bbranch(fcode_env_t *env)
{
    IP = BRANCH_IP(IP);
}

void
do_bqbranch(fcode_env_t *env)
{
    fstack_t flag;

    CHECK_DEPTH(env, 1, "b?branch");
    flag = POP(DS);
    if (flag) {
        IP++;
    } else {
        IP = BRANCH_IP(IP);
    }
}

void
do_bofbranch(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 2, "bofbranch");
    d = POP(DS);
    if (d == TOS) {
        (void) POP(DS);
        IP++;
    } else {
        IP = BRANCH_IP(IP);
    }
}

void
do_bleave(fcode_env_t *env)
{
    CHECK_RETURN_DEPTH(env, 3, "do_bleave");
    (void) POP(RS);
    (void) POP(RS);
    IP = (token_t *)POP(RS);
}

void
loop_inc(fcode_env_t *env, fstack_t inc)
{
    ufstack_t a;

    CHECK_RETURN_DEPTH(env, 2, "loop_inc");

    /*
     * Note: end condition is when the sign bit of R[0] changes.
     */
    a = RS[0];
    RS[0] += inc;
    if (((a ^ RS[0]) & SIGN_BIT) == 0) {
        IP = BRANCH_IP(IP);
    } else {
        do_bleave(env);
    }
}

void
do_bloop(fcode_env_t *env)
{
    loop_inc(env, 1);
}

void
do_bploop(fcode_env_t *env)
{
    fstack_t d;

    CHECK_DEPTH(env, 1, "+loop");
    d = POP(DS);
    loop_inc(env, d);
}

void
loop_common(fcode_env_t *env, fstack_t ptr)
{
    short offset = get_short(env);

    COMPILE_TOKEN(ptr);
    env->level--;
    compile_comma(env);
    bresolve(env);
}

void
bloop(fcode_env_t *env)
{
    loop_common(env, (fstack_t)&do_loop_ptr);
}

void
bplusloop(fcode_env_t *env)
{
    loop_common(env, (fstack_t)&do_ploop_ptr);
}

void
common_do(fcode_env_t *env, fstack_t endpt, fstack_t start, fstack_t limit)
{
    ufstack_t i, l;

    /*
     * Same computation as OBP, sets up so that loop_inc will terminate
     * when the sign bit of RS[0] changes.
     */
    i = (start - limit) - SIGN_BIT;
    l  = limit + SIGN_BIT;
    PUSH(RS, endpt);
    PUSH(RS, l);
    PUSH(RS, i);
}

void
do_bdo(fcode_env_t *env)
{
    fstack_t lo, hi;
    fstack_t endpt;

    CHECK_DEPTH(env, 2, "bdo");
    endpt = (fstack_t)BRANCH_IP(IP);
    IP++;
    lo = POP(DS);
    hi = POP(DS);
    common_do(env, endpt, lo, hi);
}

void
do_bqdo(fcode_env_t *env)
{
    fstack_t lo, hi;
    fstack_t endpt;

    CHECK_DEPTH(env, 2, "b?do");
    endpt = (fstack_t)BRANCH_IP(IP);
    IP++;
    lo = POP(DS);
    hi = POP(DS);
    if (lo == hi) {
        IP = (token_t *)endpt;
    } else {
        common_do(env, endpt, lo, hi);
    }
}

void
compile_do_common(fcode_env_t *env, fstack_t ptr)
{
    set_temporary_compile(env);
    COMPILE_TOKEN(ptr);
    bmark(env);
    COMPILE_TOKEN(0);
    bmark(env);
}

void
bdo(fcode_env_t *env)
{
    short offset = (short)get_short(env);
    compile_do_common(env, (fstack_t)&do_bdo_ptr);
}

void
bqdo(fcode_env_t *env)
{
    short offset = (short)get_short(env);
    compile_do_common(env, (fstack_t)&do_bqdo_ptr);
}

void
loop_i(fcode_env_t *env)
{
    fstack_t i;

    CHECK_RETURN_DEPTH(env, 2, "i");
    i = RS[0] + RS[-1];
    PUSH(DS, i);
}

void
loop_j(fcode_env_t *env)
{
    fstack_t j;

    CHECK_RETURN_DEPTH(env, 5, "j");
    j = RS[-3] + RS[-4];
    PUSH(DS, j);
}

void
bleave(fcode_env_t *env)
{

    if (env->state) {
        COMPILE_TOKEN(&do_leave_ptr);
    }
}

void
push_string(fcode_env_t *env, char *str, int len)
{
#define NSTRINGS    16
    static int string_count = 0;
    static int  buflen[NSTRINGS];
    static char *buffer[NSTRINGS];
    char *dest;

    if (!len) {
        PUSH(DS, 0);
        PUSH(DS, 0);
        return;
    }
    if (len != buflen[string_count]) {
        if (buffer[string_count]) FREE(buffer[string_count]);
        buffer[ string_count ] = (char *)MALLOC(len+1);
        buflen[ string_count ] = len;
    }
    dest = buffer[ string_count++ ];
    string_count = string_count%NSTRINGS;
    memcpy(dest, str, len);
    *(dest+len) = 0;
    PUSH(DS, (fstack_t)dest);
    PUSH(DS, len);
#undef NSTRINGS
}

void
parse_word(fcode_env_t *env)
{
    int len = 0;
    char *next, *dest, *here = "";

    if (env->input) {
        here = env->input->scanptr;
        while (*here == env->input->separator) here++;
        next = strchr(here, env->input->separator);
        if (next) {
            len = next - here;
            while (*next == env->input->separator) next++;
        } else {
            len = strlen(here);
            next = here + len;
        }
        env->input->scanptr = next;
    }
    push_string(env, here, len);
}

void
install_does(fcode_env_t *env)
{
    token_t *dptr;

    dptr  = (token_t *)LINK_TO_ACF(env->lastlink);

    log_message(MSG_WARN, "install_does: Last acf at: %p\n", (void *)dptr);

    *dptr = ((token_t)(IP+1)) | 1;
}

void
does(fcode_env_t *env)
{
    token_t *dptr;

    token_roundup(env, "does");

    if (env->state) {
        COMPILE_TOKEN(&does_ptr);
        COMPILE_TOKEN(&semi_ptr);
    } else {
        dptr  = (token_t *)LINK_TO_ACF(env->lastlink);
        log_message(MSG_WARN, "does: Last acf at: %p\n", (void *)dptr);
        *dptr = ((token_t)(HERE)) | 1;
        env->state |= 1;
    }
    COMPILE_TOKEN(&do_colon);
}

void
do_current(fcode_env_t *env)
{
    debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CURRENT\n");
    PUSH(DS, (fstack_t)&env->current);
}

void
do_context(fcode_env_t *env)
{
    debug_msg(DEBUG_CONTEXT, "CONTEXT:pushing &CONTEXT\n");
    PUSH(DS, (fstack_t)&CONTEXT);
}

void
do_definitions(fcode_env_t *env)
{
    env->current = CONTEXT;
    debug_msg(DEBUG_CONTEXT, "CONTEXT:definitions: %d/%p/%p\n",
        env->order_depth, CONTEXT, env->current);
}

void
make_header(fcode_env_t *env, int flags)
{
    int len;
    char *name;

    name = parse_a_string(env, &len);
    header(env, name, len, flags);
}

void
do_creator(fcode_env_t *env)
{
    make_header(env, 0);
    COMPILE_TOKEN(&do_create);
    expose_acf(env, "<create>");
}

void
create(fcode_env_t *env)
{
    if (env->state) {
        COMPILE_TOKEN(&create_ptr);
    } else
        do_creator(env);
}

void
colon(fcode_env_t *env)
{
    make_header(env, 0);
    env->state |= 1;
    COMPILE_TOKEN(&do_colon);
}

void
recursive(fcode_env_t *env)
{
    expose_acf(env, "<recursive>");
}

void
compile_string(fcode_env_t *env)
{
    int len;
    uchar_t *str, *tostr;

    COMPILE_TOKEN(&quote_ptr);
    len = POP(DS);
    str = (uchar_t *)POP(DS);
    tostr = HERE;
    *tostr++ = len;
    while (len--)
        *tostr++ = *str++;
    *tostr++ = '\0';
    set_here(env, tostr, "compile_string");
    token_roundup(env, "compile_string");
}

void
run_quote(fcode_env_t *env)
{
    char osep;

    osep = env->input->separator;
    env->input->separator = '"';
    parse_word(env);
    env->input->separator = osep;

    if (env->state) {
        compile_string(env);
    }
}

void
does_vocabulary(fcode_env_t *env)
{
    CONTEXT = WA;
    debug_msg(DEBUG_CONTEXT, "CONTEXT:vocabulary: %d/%p/%p\n",
        env->order_depth, CONTEXT, env->current);
}

void
do_vocab(fcode_env_t *env)
{
    make_header(env, 0);
    COMPILE_TOKEN(does_vocabulary);
    PUSH(DS, 0);
    compile_comma(env);
    expose_acf(env, "<vocabulary>");
}

void
do_forth(fcode_env_t *env)
{
    CONTEXT = (token_t *)(&env->forth_voc_link);
    debug_msg(DEBUG_CONTEXT, "CONTEXT:forth: %d/%p/%p\n",
        env->order_depth, CONTEXT, env->current);
}

acf_t
voc_find(fcode_env_t *env)
{
    token_t *voc;
    token_t *dptr;
    char *find_name, *name;

    voc = (token_t *)POP(DS);
    find_name = pop_a_string(env, NULL);

    for (dptr = (token_t *)(*voc); dptr; dptr = (token_t *)(*dptr)) {
        if ((name = get_name(dptr)) == NULL)
            continue;
        if (strcmp(find_name, name) == 0) {
            debug_msg(DEBUG_VOC_FIND, "%s -> %p\n", find_name,
                LINK_TO_ACF(dptr));
            return (LINK_TO_ACF(dptr));
        }
    }
    debug_msg(DEBUG_VOC_FIND, "%s not found\n", find_name);
    return (NULL);
}

void
dollar_find(fcode_env_t *env)
{
    acf_t acf = NULL;
    int i;

    CHECK_DEPTH(env, 2, "$find");
    for (i = env->order_depth; i >= 0 && env->order[i] && !acf; i--) {
        two_dup(env);
        PUSH(DS, (fstack_t)env->order[i]);
        acf = voc_find(env);
    }
    if (acf) {
        two_drop(env);
        PUSH(DS, (fstack_t)acf);
        PUSH(DS, TRUE);
    } else
        PUSH(DS, FALSE);
}

void
interpret(fcode_env_t *env)
{
    char *name;

    parse_word(env);
    while (TOS) {
        two_dup(env);
        dollar_find(env);
        if (TOS) {
            flag_t *flags;

            drop(env);
            nip(env);
            nip(env);
            flags = LINK_TO_FLAGS(ACF_TO_LINK(TOS));

            if ((env->state) &&
                ((*flags & IMMEDIATE) == 0)) {
                /* Compile in references */
                compile_comma(env);
            } else {
                execute(env);
            }
        } else {
            int bad;
            drop(env);
            dollar_number(env);
            bad = POP(DS);
            if (bad) {
                two_dup(env);
                name = pop_a_string(env, NULL);
                log_message(MSG_INFO, "%s?\n", name);
                break;
            } else {
                nip(env);
                nip(env);
                literal(env);
            }
        }
        parse_word(env);
    }
    two_drop(env);
}

void
evaluate(fcode_env_t *env)
{
    input_typ *old_input = env->input;
    input_typ *eval_bufp = MALLOC(sizeof (input_typ));

    CHECK_DEPTH(env, 2, "evaluate");
    eval_bufp->separator = ' ';
    eval_bufp->maxlen = POP(DS);
    eval_bufp->buffer = (char *)POP(DS);
    eval_bufp->scanptr = eval_bufp->buffer;
    env->input = eval_bufp;
    interpret(env);
    FREE(eval_bufp);
    env->input = old_input;
}

void
make_common_access(fcode_env_t *env,
    char *name, int len,
    int ncells,
    int instance_mode,
    void (*acf_instance)(fcode_env_t *env),
    void (*acf_static)(fcode_env_t *env),
    void (*set_action)(fcode_env_t *env, int))
{
    if (instance_mode && !MYSELF) {
        system_message(env, "No instance context");
    }

    debug_msg(DEBUG_ACTIONS, "make_common_access:%s '%s', %d\n",
        (instance_mode ? "instance" : ""),
        (name ? name : ""), ncells);

    if (len)
        header(env, name, len, 0);
    if (instance_mode) {
        token_t *dptr;
        int offset;

        COMPILE_TOKEN(acf_instance);
        dptr = alloc_instance_data(env, INIT_DATA, ncells, &offset);
        debug_msg(DEBUG_ACTIONS, "Data: %p, offset %d\n", (char *)dptr,
            offset);
        PUSH(DS, offset);
        compile_comma(env);
        while (ncells--)
            *dptr++ = MYSELF->data[INIT_DATA][offset++] = POP(DS);
        env->instance_mode = 0;
    } else {
        COMPILE_TOKEN(acf_static);
        while (ncells--)
            compile_comma(env);
    }
    expose_acf(env, name);
    if (set_action)
        set_action(env, instance_mode);
}

void
do_constant(fcode_env_t *env)
{
    PUSH(DS, (variable_t)(*WA));
}

void
do_crash(fcode_env_t *env)
{
    forth_abort(env, "Unitialized defer");
}

/*
 * 'behavior' Fcode retrieve execution behavior for a defer word.
 */
static void
behavior(fcode_env_t *env)
{
    acf_t defer_xt;
    token_t token;
    acf_t contents_xt;

    CHECK_DEPTH(env, 1, "behavior");
    defer_xt = (acf_t)POP(DS);
    token = *defer_xt;
    contents_xt = (token_t *)(token & ~1);
    if ((token & 1) == 0 || *contents_xt != (token_t)&do_default_action)
        forth_abort(env, "behavior: bad xt: %p indir: %x/%p\n",
            defer_xt, token & 1, *contents_xt);
    defer_xt++;
    PUSH(DS, *((variable_t *)defer_xt));
}

void
fc_abort(fcode_env_t *env, char *type)
{
    forth_abort(env, "%s Fcode '%s' Executed", type,
        acf_to_name(env, WA - 1));
}

void
f_abort(fcode_env_t *env)
{
    fc_abort(env, "Abort");
}

/*
 * Fcodes chosen not to support.
 */
void
fc_unimplemented(fcode_env_t *env)
{
    fc_abort(env, "Unimplemented");
}

/*
 * Fcodes that are Obsolete per P1275-1994.
 */
void
fc_obsolete(fcode_env_t *env)
{
    fc_abort(env, "Obsolete");
}

/*
 * Fcodes that are Historical per P1275-1994
 */
void
fc_historical(fcode_env_t *env)
{
    fc_abort(env, "Historical");
}

void
catch(fcode_env_t *env)
{
    error_frame *new;

    CHECK_DEPTH(env, 1, "catch");
    new = MALLOC(sizeof (error_frame));
    new->ds     = DS-1;
    new->rs     = RS;
    new->myself = MYSELF;
    new->next   = env->catch_frame;
    new->code   = 0;
    env->catch_frame = new;
    execute(env);
    PUSH(DS, new->code);
    env->catch_frame = new->next;
    FREE(new);
}

void
throw_from_fclib(fcode_env_t *env, fstack_t errcode, char *fmt, ...)
{
    error_frame *efp;
    va_list ap;
    char msg[256];

    va_start(ap, fmt);
    vsprintf(msg, fmt, ap);

    if (errcode) {

        env->last_error = errcode;

        /*
         * No catch frame set => fatal error
         */
        efp = env->catch_frame;
        if (!efp)
            forth_abort(env, "%s: No catch frame", msg);

        debug_msg(DEBUG_TRACING, "throw_from_fclib: throw: %s\n", msg);

        /*
         * Setting IP=0 will force the unwinding of the calls
         * (see execute) which is how we will return (eventually)
         * to the test in catch that follows 'execute'.
         */
        DS      = efp->ds;
        RS      = efp->rs;
        MYSELF      = efp->myself;
        IP      = 0;
        efp->code   = errcode;
    }
}

void
throw(fcode_env_t *env)
{
    fstack_t t;

    CHECK_DEPTH(env, 1, "throw");
    t = POP(DS);
    if (t >= -20 && t <= 20)
        throw_from_fclib(env, t, "throw Fcode errcode: 0x%x", (int)t);
    else {
        if (t)
            log_message(MSG_ERROR, "throw: errcode: 0x%x\n",
                (int)t);
        throw_from_fclib(env, t, "throw Fcode err: %s", (char *)t);
    }
}

void
tick_literal(fcode_env_t *env)
{
    if (env->state) {
        COMPILE_TOKEN(&tlit_ptr);
        compile_comma(env);
    }
}

void
do_tick(fcode_env_t *env)
{
    parse_word(env);
    dollar_find(env);
    invert(env);
    throw(env);
    tick_literal(env);
}

void
bracket_tick(fcode_env_t *env)
{
    do_tick(env);
}

#pragma init(_init)

static void
_init(void)
{
    fcode_env_t *env = initial_env;

    NOTICE;
    ASSERT(env);

    ANSI(0x019, 0,      "i",            loop_i);
    ANSI(0x01a, 0,      "j",            loop_j);
    ANSI(0x01d, 0,      "execute",      execute);
    ANSI(0x01e, 0,      "+",            add);
    ANSI(0x01f, 0,      "-",            subtract);
    ANSI(0x020, 0,      "*",            multiply);
    ANSI(0x021, 0,      "/",            divide);
    ANSI(0x022, 0,      "mod",          mod);
    FORTH(0,        "/mod",         slash_mod);
    ANSI(0x023, 0,      "and",          and);
    ANSI(0x024, 0,      "or",           or);
    ANSI(0x025, 0,      "xor",          xor);
    ANSI(0x026, 0,      "invert",       invert);
    ANSI(0x027, 0,      "lshift",       lshift);
    ANSI(0x028, 0,      "rshift",       rshift);
    ANSI(0x029, 0,      ">>a",          rshifta);
    ANSI(0x02a, 0,      "/mod",         slash_mod);
    ANSI(0x02b, 0,      "u/mod",        uslash_mod);
    ANSI(0x02c, 0,      "negate",       negate);
    ANSI(0x02d, 0,      "abs",          f_abs);
    ANSI(0x02e, 0,      "min",          f_min);
    ANSI(0x02f, 0,      "max",          f_max);
    ANSI(0x030, 0,      ">r",           to_r);
    ANSI(0x031, 0,      "r>",           from_r);
    ANSI(0x032, 0,      "r@",           rfetch);
    ANSI(0x033, 0,      "exit",         f_exit);
    ANSI(0x034, 0,      "0=",           zero_equals);
    ANSI(0x035, 0,      "0<>",          zero_not_equals);
    ANSI(0x036, 0,      "0<",           zero_less);
    ANSI(0x037, 0,      "0<=",          zero_less_equals);
    ANSI(0x038, 0,      "0>",           zero_greater);
    ANSI(0x039, 0,      "0>=",          zero_greater_equals);
    ANSI(0x03a, 0,      "<",            less);
    ANSI(0x03b, 0,      ">",            greater);
    ANSI(0x03c, 0,      "=",            equals);
    ANSI(0x03d, 0,      "<>",           not_equals);
    ANSI(0x03e, 0,      "u>",           unsign_greater);
    ANSI(0x03f, 0,      "u<=",          unsign_less_equals);
    ANSI(0x040, 0,      "u<",           unsign_less);
    ANSI(0x041, 0,      "u>=",          unsign_greater_equals);
    ANSI(0x042, 0,      ">=",           greater_equals);
    ANSI(0x043, 0,      "<=",           less_equals);
    ANSI(0x044, 0,      "between",      between);
    ANSI(0x045, 0,      "within",       within);
    ANSI(0x046, 0,      "drop",         drop);
    ANSI(0x047, 0,      "dup",          f_dup);
    ANSI(0x048, 0,      "over",         over);
    ANSI(0x049, 0,      "swap",         swap);
    ANSI(0x04a, 0,      "rot",          rot);
    ANSI(0x04b, 0,      "-rot",         minus_rot);
    ANSI(0x04c, 0,      "tuck",         tuck);
    ANSI(0x04d, 0,      "nip",          nip);
    ANSI(0x04e, 0,      "pick",         pick);
    ANSI(0x04f, 0,      "roll",         roll);
    ANSI(0x050, 0,      "?dup",         qdup);
    ANSI(0x051, 0,      "depth",        depth);
    ANSI(0x052, 0,      "2drop",        two_drop);
    ANSI(0x053, 0,      "2dup",         two_dup);
    ANSI(0x054, 0,      "2over",        two_over);
    ANSI(0x055, 0,      "2swap",        two_swap);
    ANSI(0x056, 0,      "2rot",         two_rot);
    ANSI(0x057, 0,      "2/",           two_slash);
    ANSI(0x058, 0,      "u2/",          utwo_slash);
    ANSI(0x059, 0,      "2*",           two_times);
    ANSI(0x05a, 0,      "/c",           slash_c);
    ANSI(0x05b, 0,      "/w",           slash_w);
    ANSI(0x05c, 0,      "/l",           slash_l);
    ANSI(0x05d, 0,      "/n",           slash_n);
    ANSI(0x05e, 0,      "ca+",          ca_plus);
    ANSI(0x05f, 0,      "wa+",          wa_plus);
    ANSI(0x060, 0,      "la+",          la_plus);
    ANSI(0x061, 0,      "na+",          na_plus);
    ANSI(0x062, 0,      "char+",        char_plus);
    ANSI(0x063, 0,      "wa1+",         wa1_plus);
    ANSI(0x064, 0,      "la1+",         la1_plus);
    ANSI(0x065, 0,      "cell+",        cell_plus);
    ANSI(0x066, 0,      "chars",        do_chars);
    ANSI(0x067, 0,      "/w*",          slash_w_times);
    ANSI(0x068, 0,      "/l*",          slash_l_times);
    ANSI(0x069, 0,      "cells",        cells);
    ANSI(0x06a, 0,      "on",           do_on);
    ANSI(0x06b, 0,      "off",          do_off);
    ANSI(0x06c, 0,      "+!",           addstore);
    ANSI(0x06d, 0,      "@",            fetch);
    ANSI(0x06e, 0,      "l@",           lfetch);
    ANSI(0x06f, 0,      "w@",           wfetch);
    ANSI(0x070, 0,      "<w@",          swfetch);
    ANSI(0x071, 0,      "c@",           cfetch);
    ANSI(0x072, 0,      "!",            store);
    ANSI(0x073, 0,      "l!",           lstore);
    ANSI(0x074, 0,      "w!",           wstore);
    ANSI(0x075, 0,      "c!",           cstore);
    ANSI(0x076, 0,      "2@",           two_fetch);
    ANSI(0x077, 0,      "2!",           two_store);
    ANSI(0x078, 0,      "move",         fc_move);
    ANSI(0x079, 0,      "fill",         fc_fill);
    ANSI(0x07a, 0,      "comp",         fc_comp);
    ANSI(0x07b, 0,      "noop",         noop);
    ANSI(0x07c, 0,      "lwsplit",      lwsplit);
    ANSI(0x07d, 0,      "wljoin",       wljoin);
    ANSI(0x07e, 0,      "lbsplit",      lbsplit);
    ANSI(0x07f, 0,      "bljoin",       bljoin);
    ANSI(0x080, 0,      "wbflip",       wbflip);
    ANSI(0x081, 0,      "upc",          upper_case);
    ANSI(0x082, 0,      "lcc",          lower_case);
    ANSI(0x083, 0,      "pack",         pack_str);
    ANSI(0x084, 0,      "count",        count_str);
    ANSI(0x085, 0,      "body>",        to_acf);
    ANSI(0x086, 0,      ">body",        to_body);

    ANSI(0x089, 0,      "unloop",       unloop);

    ANSI(0x09f, 0,      ".s",           dot_s);
    ANSI(0x0a0, 0,      "base",         base);
    FCODE(0x0a1, 0,     "convert",      fc_historical);
    ANSI(0x0a2, 0,      "$number",      dollar_number);
    ANSI(0x0a3, 0,      "digit",        digit);

    ANSI(0x0a9, 0,      "bl",           space);
    ANSI(0x0aa, 0,      "bs",           backspace);
    ANSI(0x0ab, 0,      "bell",         bell);
    ANSI(0x0ac, 0,      "bounds",       fc_bounds);
    ANSI(0x0ad, 0,      "here",         here);

    ANSI(0x0af, 0,      "wbsplit",      wbsplit);
    ANSI(0x0b0, 0,      "bwjoin",       bwjoin);

    P1275(0x0cb, 0,     "$find",        dollar_find);

    ANSI(0x0d0, 0,      "c,",           ccomma);
    ANSI(0x0d1, 0,      "w,",           wcomma);
    ANSI(0x0d2, 0,      "l,",           lcomma);
    ANSI(0x0d3, 0,      ",",            comma);
    ANSI(0x0d4, 0,      "um*",          um_multiply);
    ANSI(0x0d5, 0,      "um/mod",       um_slash_mod);

    ANSI(0x0d8, 0,      "d+",           d_plus);
    ANSI(0x0d9, 0,      "d-",           d_minus);

    ANSI(0x0dc, 0,      "state",        state);
    ANSI(0x0de, 0,      "behavior",     behavior);
    ANSI(0x0dd, 0,      "compile,",     compile_comma);

    ANSI(0x216, 0,      "abort",        f_abort);
    ANSI(0x217, 0,      "catch",        catch);
    ANSI(0x218, 0,      "throw",        throw);

    ANSI(0x226, 0,      "lwflip",       lwflip);
    ANSI(0x227, 0,      "lbflip",       lbflip);
    ANSI(0x228, 0,      "lbflips",      lbflips);

    ANSI(0x236, 0,      "wbflips",      wbflips);
    ANSI(0x237, 0,      "lwflips",      lwflips);

    FORTH(0,        "forth",        do_forth);
    FORTH(0,        "current",      do_current);
    FORTH(0,        "context",      do_context);
    FORTH(0,        "definitions",      do_definitions);
    FORTH(0,        "vocabulary",       do_vocab);
    FORTH(IMMEDIATE,    ":",            colon);
    FORTH(IMMEDIATE,    ";",            semi);
    FORTH(IMMEDIATE,    "create",       create);
    FORTH(IMMEDIATE,    "does>",        does);
    FORTH(IMMEDIATE,    "recursive",        recursive);
    FORTH(0,        "parse-word",       parse_word);
    FORTH(IMMEDIATE,    "\"",           run_quote);
    FORTH(IMMEDIATE,    "order",        do_order);
    FORTH(IMMEDIATE,    "also",         do_also);
    FORTH(IMMEDIATE,    "previous",     do_previous);
    FORTH(IMMEDIATE,    "'",            do_tick);
    FORTH(IMMEDIATE,    "[']",          bracket_tick);
    FORTH(0,        "unaligned-l@",     unaligned_lfetch);
    FORTH(0,        "unaligned-l!",     unaligned_lstore);
    FORTH(0,        "unaligned-w@",     unaligned_wfetch);
    FORTH(0,        "unaligned-w!",     unaligned_wstore);
}