efcode/engine/debug.c

/*
 * CDDL HEADER START
 *
 * The contents of this file are subject to the terms of the
 * Common Development and Distribution License (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, 2010, Oracle and/or its affiliates. All rights reserved.
 */

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

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

#ifndef DEBUG_LVL
#define DEBUG_LVL   0
#endif

struct bitab {
    token_t bi_ptr;
    char *bi_name;
    int bi_type;
};

struct bitab *lookup_builtin(token_t);

static int debug_level = DEBUG_LVL;

void
set_interpreter_debug_level(long lvl)
{
    debug_level = lvl;
}

long
get_interpreter_debug_level(void)
{
    return (debug_level);
}

void
output_data_stack(fcode_env_t *env, int msglevel)
{
    int i;

    log_message(msglevel, "( ");
    if (DS > env->ds0) {
        for (i = 0; i < (DS - env->ds0); i++)
            log_message(msglevel, "%llx ",
                (uint64_t)(env->ds0[i + 1]));
    } else
        log_message(msglevel, "<empty> ");
    log_message(msglevel, ") ");
}

void
output_return_stack(fcode_env_t *env, int show_wa, int msglevel)
{
    int i;
    int anyout = 0;

    log_message(msglevel, "R:( ");
    if (show_wa) {
        log_message(msglevel, "%s ",
            acf_backup_search(env, (acf_t)WA));
        anyout++;
    }
    if (IP) {
        anyout++;
        log_message(msglevel, "%s ", acf_backup_search(env, IP));
    }
    for (i = (RS - env->rs0) - 1; i > 0; i--) {
        anyout++;
        log_message(msglevel, "%s ",
            acf_backup_search(env, (acf_t)env->rs0[i+1]));
    }
    if (!anyout)
        log_message(msglevel, "<empty> ");
    log_message(msglevel, ") ");
}

void
dump_comma(fcode_env_t *env, char *type)
{
    xforth_t d;

    if (strcmp(type, "x,") == 0)
        d = peek_xforth(env);
    else
        d = TOS;
    log_message(MSG_FC_DEBUG, "%s %p, %llx\n", type, HERE, (uint64_t)d);
}

static int ndebug_names;
#define MAXDEBUG_NAMES  10
static char *debug_names[MAXDEBUG_NAMES];

static int ndebug_acfs;
#define MAXDEBUG_ACFS   10
static acf_t debug_acfs[MAXDEBUG_ACFS];

void
add_debug_acf(fcode_env_t *env, acf_t acf)
{
    int i;

    for (i = 0; i < ndebug_acfs; i++)
        if (acf == debug_acfs[i])
            return;

    if (!within_dictionary(env, acf))
        log_message(MSG_ERROR, "Can't debug builtin\n");
    else if (ndebug_acfs >= MAXDEBUG_ACFS)
        log_message(MSG_ERROR, "Too many debug ACF's\n");
    else {
        debug_acfs[ndebug_acfs++] = acf;
        *LINK_TO_FLAGS(ACF_TO_LINK(acf)) |= FLAG_DEBUG;
    }
}

static void
paren_debug(fcode_env_t *env)
{
    acf_t acf;

    acf = (acf_t)POP(DS);
    if (!within_dictionary(env, acf)) {
        log_message(MSG_INFO, "acf: %llx not in dictionary\n",
            (uint64_t)acf);
        return;
    }
    if ((acf_t)_ALIGN(acf, token_t) != acf) {
        log_message(MSG_INFO, "acf: %llx not aligned\n",
            (uint64_t)acf);
        return;
    }
    if (*acf != (token_t)(&do_colon)) {
        log_message(MSG_INFO, "acf: %llx not a colon-def\n",
            (uint64_t)acf);
        return;
    }
    add_debug_acf(env, acf);
}

static void
debug(fcode_env_t *env)
{
    fstack_t d;
    char *word;
    acf_t acf;

    parse_word(env);
    dollar_find(env);
    d = POP(DS);
    if (d) {
        acf = (acf_t)POP(DS);
        add_debug_acf(env, acf);
    } else if (ndebug_names >= MAXDEBUG_NAMES) {
        log_message(MSG_ERROR, "Too many forward debug words\n");
        two_drop(env);
    } else {
        word = pop_a_duped_string(env, NULL);
        log_message(MSG_INFO, "Forward defined word: %s\n", word);
        debug_names[ndebug_names++] = word;
    }
}

/*
 * Eliminate dups and add vocabulary forth to end if not already on list.
 */
static void
order_to_dict_list(fcode_env_t *env, token_t *order[])
{
    int i, j, norder = 0;

    if (env->current)
        order[norder++] = env->current;
    for (i = env->order_depth; i >= 0; i--) {
        for (j = 0; j < norder && order[j] != env->order[i]; j++)
            ;
        if (j == norder)
            order[norder++] = env->order[i];
    }
    for (j = 0; j < norder && order[j] != (token_t *)&env->forth_voc_link;
        j++)
        ;
    if (j == norder)
        order[norder++] = (token_t *)&env->forth_voc_link;
    order[norder] = NULL;
}

static acf_t
search_all_dictionaries(fcode_env_t *env,
    acf_t (*fn)(fcode_env_t *, acf_t, void *),
    void *arg)
{
    token_t *order[MAX_ORDER+1];
    int i;
    token_t *dptr;
    acf_t acf;

    order_to_dict_list(env, order);
    for (i = 0; (dptr = order[i]) != NULL; i++) {
        for (dptr = (token_t *)(*dptr); dptr;
            dptr = (token_t *)(*dptr))
            if ((acf = (*fn)(env, LINK_TO_ACF(dptr), arg)) != NULL)
                return (acf);
    }
    return (NULL);
}

char *
acf_to_str(acf_t acf)
{
    static char msg[(sizeof (acf) * 2) + 3];

    sprintf(msg, "(%08p)", acf);
    return (msg);
}

char *
get_name_or_acf(token_t *dptr)
{
    char *name;

    if ((name = get_name(dptr)) != NULL)
        return (name);
    return (acf_to_str(LINK_TO_ACF(dptr)));
}

static void
output_acf_name(acf_t acf)
{
    char *name;
    token_t *dptr;
    static int acf_count = 0;

    if (acf == NULL) {
        if (acf_count)
            log_message(MSG_INFO, "\n");
        acf_count = 0;
        return;
    }
    dptr = ACF_TO_LINK(acf);
    if ((name = get_name(dptr)) == NULL)
        name = "<noname>";

    log_message(MSG_INFO, "%24s (%08p)", name, acf);
    if (++acf_count >= 2) {
        log_message(MSG_INFO, "\n");
        acf_count = 0;
    } else
        log_message(MSG_INFO, "    ");
}

static void
dot_debug(fcode_env_t *env)
{
    int i;
    token_t *dptr;

    if (ndebug_names == 0)
        log_message(MSG_INFO, "No forward debug words\n");
    else {
        for (i = 0; i < ndebug_names; i++)
            log_message(MSG_INFO, "%s Forward\n", debug_names[i]);
    }
    if (ndebug_acfs == 0)
        log_message(MSG_INFO, "No debug words\n");
    else {
        for (i = 0; i < ndebug_acfs; i++)
            log_message(MSG_INFO, "%s\n",
                get_name_or_acf(ACF_TO_LINK(debug_acfs[i])));
    }
}

static void
do_undebug(fcode_env_t *env, char *name)
{
    int i;

    for (i = 0; i < ndebug_names; i++) {
        if (strcmp(debug_names[i], name) == 0) {
            log_message(MSG_INFO, "Undebugging forward word %s\n",
                name);
            FREE(debug_names[i]);
            for (i++; i < ndebug_names; i++)
                debug_names[i - 1] = debug_names[i];
            ndebug_names--;
            break;
        }
    }
}

static void
undebug(fcode_env_t *env)
{
    fstack_t d;
    acf_t acf;
    flag_t *flagp;
    char *name;
    int i, j;

    parse_word(env);
    two_dup(env);
    dollar_find(env);
    d = POP(DS);
    if (d) {
        acf = (acf_t)POP(DS);
        flagp = LINK_TO_FLAGS(ACF_TO_LINK(acf));
        if ((*flagp & FLAG_DEBUG) == 0)
            log_message(MSG_WARN, "Word not debugged?\n");
        else {
            log_message(MSG_INFO, "Undebugging acf: %p\n", acf);
            *flagp &= ~FLAG_DEBUG;
            for (i = 0; i < ndebug_acfs; i++) {
                if (debug_acfs[i] == acf) {
                    for (j = i + 1; j < ndebug_acfs; j++)
                        debug_acfs[j-1] = debug_acfs[j];
                    ndebug_acfs--;
                    break;
                }
            }
        }
    } else
        two_drop(env);
    name = pop_a_string(env, NULL);
    do_undebug(env, name);
}

int
name_is_debugged(fcode_env_t *env, char *name)
{
    int i;

    if (ndebug_names <= 0)
        return (0);
    for (i = 0; i < ndebug_names; i++)
        if (strcmp(debug_names[i], name) == 0)
            return (1);
    return (0);
}

/*
 * This is complicated by being given ACF's to temporary compile words which
 * don't have a header.
 */
int
is_debug_word(fcode_env_t *env, acf_t acf)
{
    flag_t *flagp;
    int i;

    /* check to see if any words are being debugged */
    if (ndebug_acfs == 0)
        return (0);

    /* only words in dictionary can be debugged */
    if (!within_dictionary(env, acf))
        return (0);

    /* check that word has "FLAG_DEBUG" on */
    flagp = LINK_TO_FLAGS(ACF_TO_LINK(acf));
    if ((*flagp & FLAG_DEBUG) == 0)
        return (0);

    /* look in table of debug acf's */
    for (i = 0; i < ndebug_acfs; i++)
        if (debug_acfs[i] == acf)
            return (1);
    return (0);
}

#define MAX_DEBUG_STACK 100
token_t debug_low[MAX_DEBUG_STACK], debug_high[MAX_DEBUG_STACK];
int debug_prev_level[MAX_DEBUG_STACK];
int debug_curr_level[MAX_DEBUG_STACK];
int ndebug_stack = 0;

void
debug_set_level(fcode_env_t *env, int level)
{
    debug_curr_level[ndebug_stack - 1] = level;
    set_interpreter_debug_level(level);
}

token_t
find_semi_in_colon_def(fcode_env_t *env, acf_t acf)
{
    for (; within_dictionary(env, acf); acf++)
        if (*acf == (token_t)(&semi_ptr))
            return ((token_t)acf);
    return (0);
}

void
check_for_debug_entry(fcode_env_t *env)
{
    int top;

    if (is_debug_word(env, WA) && ndebug_stack < MAX_DEBUG_STACK) {
        top = ndebug_stack++;
        debug_prev_level[top] = get_interpreter_debug_level();
        debug_low[top] = (token_t)WA;
        if (*WA == (token_t)(&do_colon)) {
            debug_high[top] =
                find_semi_in_colon_def(env, WA);
        } else {
            debug_high[top] = 0;    /* marker... */
        }
        debug_set_level(env, DEBUG_STEPPING);
        output_step_message(env);
    }
}

void
check_for_debug_exit(fcode_env_t *env)
{
    if (ndebug_stack) {
        int top = ndebug_stack - 1;

        if (debug_high[top] == 0) {
            set_interpreter_debug_level(debug_prev_level[top]);
            ndebug_stack--;
        } else if ((token_t)IP >= debug_low[top] &&
            (token_t)IP <= debug_high[top]) {
            set_interpreter_debug_level(debug_curr_level[top]);
        } else {
            set_interpreter_debug_level(debug_prev_level[top]);
        }
    }
}

void
check_semi_debug_exit(fcode_env_t *env)
{
    if (ndebug_stack) {
        int top = ndebug_stack - 1;

        if ((token_t)(IP - 1) == debug_high[top]) {
            set_interpreter_debug_level(debug_prev_level[top]);
            ndebug_stack--;
        }
    }
}

/*
 * Really entering do_run, since this may be a recursive entry to do_run,
 * we need to set the debug level to what it was previously.
 */
int
current_debug_state(fcode_env_t *env)
{
    if (ndebug_stack) {
        int top = ndebug_stack - 1;
        set_interpreter_debug_level(debug_prev_level[top]);
    }
    return (ndebug_stack);
}

void
clear_debug_state(fcode_env_t *env, int oldstate)
{
    if (ndebug_stack && oldstate <= ndebug_stack) {
        set_interpreter_debug_level(debug_prev_level[oldstate]);
        ndebug_stack = oldstate;
    }
}

void
unbug(fcode_env_t *env)
{
    int i;
    token_t *link;
    flag_t *flag;

    for (i = ndebug_stack - 1; i >= 0; i--) {
        link = ACF_TO_LINK(debug_low[i]);
        flag = LINK_TO_FLAGS(link);
        *flag &= ~FLAG_DEBUG;
    }
    clear_debug_state(env, 0);
}

void
output_vitals(fcode_env_t *env)
{
    log_message(MSG_FC_DEBUG, "IP=%p, *IP=%p, WA=%p, *WA=%p ", IP,
        (IP ? *IP : 0), WA, (WA ? *WA : 0));
}

int
do_exec_debug(fcode_env_t *env, void *fn)
{
    int dl = debug_level;
    int show_wa = 1;

    if ((dl & (DEBUG_EXEC_DUMP_DS | DEBUG_EXEC_DUMP_RS |
        DEBUG_EXEC_SHOW_VITALS | DEBUG_EXEC_TRACE | DEBUG_TRACING |
        DEBUG_STEPPING)) == 0)
        return (0);

    if (dl & DEBUG_STEPPING) {
        dl |= DEBUG_EXEC_DUMP_DS;
    }
    if (dl & (DEBUG_STEPPING | DEBUG_EXEC_TRACE)) {
        log_message(MSG_FC_DEBUG, "%-15s ", acf_to_name(env, WA));
        show_wa = 0;
    }
    if (dl & DEBUG_EXEC_DUMP_DS)
        output_data_stack(env, MSG_FC_DEBUG);
    if (dl & DEBUG_EXEC_DUMP_RS)
        output_return_stack(env, show_wa, MSG_FC_DEBUG);
    if (dl & DEBUG_EXEC_SHOW_VITALS)
        output_vitals(env);
    if (dl & DEBUG_TRACING)
        do_fclib_trace(env, (void *) fn);
    log_message(MSG_FC_DEBUG, "\n");
    if (dl & DEBUG_STEPPING)
        return (do_fclib_step(env));
    return (0);
}

static void
smatch(fcode_env_t *env)
{
    int len;
    char *str, *p;

    if ((str = parse_a_string(env, &len)) == NULL)
        log_message(MSG_INFO, "smatch: no string\n");
    else {
        for (p = (char *)env->base; p < (char *)HERE; p++)
            if (memcmp(p, str, len) == 0)
                log_message(MSG_DEBUG, "%p\n", p);
    }
}

void
check_vitals(fcode_env_t *env)
{
    int i;
    token_t *dptr;

    dptr = env->current;
    if (*dptr && !within_dictionary(env, (uchar_t *)*dptr))
        log_message(MSG_ERROR, "Current: %p outside dictionary\n",
            *dptr);
    for (i = env->order_depth; i >= 0; i--) {
        dptr = env->order[i];
        if (!dptr)
            continue;
        if (*dptr && !within_dictionary(env, (uchar_t *)*dptr))
            log_message(MSG_ERROR, "Order%d: %p outside"
                " dictionary\n", i, *dptr);
    }
    if (HERE < env->base || HERE >= env->base + dict_size) {
        log_message(MSG_ERROR, "HERE: %p outside range\n", HERE);
    }
    if (DS < env->ds0 || DS >= &env->ds0[stack_size]) {
        forth_abort(env, "DS: %p outside range\n", DS);
    }
    if (RS < env->rs0 || RS >= &env->rs0[stack_size]) {
        log_message(MSG_ERROR, "RS: %p outside range\n", RS);
        RS = env->rs0;
    }
    if (IP && !within_dictionary(env, IP))
        log_message(MSG_ERROR, "IP: %p outside dictionary\n", IP);
    if (!within_dictionary(env, (void *)env->forth_voc_link))
        log_message(MSG_ERROR, "forth_voc_link: %p outside"
            " dictionary\n", env->forth_voc_link);
}

static void
dump_table(fcode_env_t *env)
{
    int i;

    for (i = 0; i < MAX_FCODE; i++) {
        if (*(env->table[i].apf) != (token_t)(&f_error)) {
            log_message(MSG_DEBUG, "Token: %4x %32s acf = %8p,"
                " %8p\n", i, env->table[i].name, env->table[i].apf,
                *(env->table[i].apf));
        }
    }
    log_message(MSG_DEBUG, "%d FCODES implemented\n", fcode_impl_count);
}

void
verify_usage(fcode_env_t *env)
{
    int i, untested = 0;

    for (i = 0; i < MAX_FCODE; i++) {
        int verify;

        verify = env->table[i].flags & (ANSI_WORD|P1275_WORD);
        if ((verify) &&
#ifdef DEBUG
            (env->table[i].usage == 0) &&
#endif
            (env->table[i].apf)) {
            log_message(MSG_DEBUG,
                "Untested: %4x %32s acf = %8p, %8p\n", i,
                env->table[i].name, env->table[i].apf,
                *(env->table[i].apf));
            untested++;
        }
    }
    if (untested)
        log_message(MSG_DEBUG, "%d untested tokens\n", untested);
}

static void
debugf(fcode_env_t *env)
{
    PUSH(DS, (fstack_t)&debug_level);
}

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

struct bittab {
    int b_bitval;
    char *b_bitname;
} bittab[] = {
    DEBUG_CONTEXT,      "context",
    DEBUG_BYTELOAD_DS,  "byteload-ds",
    DEBUG_BYTELOAD_RS,  "byteload-rs",
    DEBUG_BYTELOAD_TOKENS,  "byteload-tokens",
    DEBUG_NEW_TOKEN,    "new-token",
    DEBUG_EXEC_TRACE,   "exec-trace",
    DEBUG_EXEC_SHOW_VITALS, "exec-show-vitals",
    DEBUG_EXEC_DUMP_DS, "exec-dump-ds",
    DEBUG_EXEC_DUMP_RS, "exec-dump-rs",
    DEBUG_COMMA,        "comma",
    DEBUG_HEADER,       "header",
    DEBUG_EXIT_WORDS,   "exit-words",
    DEBUG_EXIT_DUMP,    "exit-dump",
    DEBUG_DUMP_TOKENS,  "dump-tokens",
    DEBUG_COLON,        "colon",
    DEBUG_NEXT_VITALS,  "next-vitals",
    DEBUG_VOC_FIND,     "voc-find",
    DEBUG_DUMP_DICT_TOKENS, "dump-dict-tokens",
    DEBUG_TOKEN_USAGE,  "token-usage",
    DEBUG_DUMP_TOKEN_TABLE, "dump-token-table",
    DEBUG_SHOW_STACK,   "show-stack",
    DEBUG_SHOW_RS,      "show-rs",
    DEBUG_TRACING,      "tracing",
    DEBUG_TRACE_STACK,  "trace-stack",
    DEBUG_CALL_METHOD,  "call-method",
    DEBUG_ACTIONS,      "actions",
    DEBUG_STEPPING,     "stepping",
    DEBUG_REG_ACCESS,   "reg-access",
    DEBUG_ADDR_ABUSE,   "addr-abuse",
    DEBUG_FIND_FCODE,   "find-fcode",
    DEBUG_UPLOAD,       "upload",
    0
};

void
debug_flags_to_output(fcode_env_t *env, int flags)
{
    int first = 1, i;

    for (i = 0; bittab[i].b_bitval != 0; i++)
        if (bittab[i].b_bitval & flags) {
            if (!first)
                log_message(MSG_INFO, ",");
            first = 0;
            log_message(MSG_INFO, bittab[i].b_bitname);
        }
    if (first)
        log_message(MSG_INFO, "<empty>");
    log_message(MSG_INFO, "\n");
}

static void
dot_debugf(fcode_env_t *env)
{
    debug_flags_to_output(env, debug_level);
}

static void
debugf_qmark(fcode_env_t *env)
{
    debug_flags_to_output(env, 0xffffffff);
}

int
debug_flags_to_mask(char *str)
{
    int flags = 0;
    char *p;
    int i;

    if (isdigit(*str)) {
        if (*str == '0') {
            str++;
            if (*str == 'x' || *str == 'X') {
                sscanf(str + 1, "%x", &flags);
            } else
                sscanf(str, "%o", &flags);
        } else
            sscanf(str, "%d", &flags);
        return (flags);
    }
    if (strcmp(str, "clear") == 0)
        return (0);
    if (strcmp(str, "all") == 0)
        return (0xffffffff & ~DEBUG_STEPPING);
    if (*str) {
        do {
            if (p = strchr(str, ','))
                *p++ = '\0';
            for (i = 0; bittab[i].b_bitname != 0; i++)
                if (strcmp(str, bittab[i].b_bitname) == 0) {
                    flags |= bittab[i].b_bitval;
                    break;
            }
            if (bittab[i].b_bitname == 0)
                log_message(MSG_WARN,
                    "Unknown debug flag: '%s'\n", str);
            str = p;
        } while (p);
    }
    return (flags);
}

static void
set_debugf(fcode_env_t *env)
{
    char *str;

    str = parse_a_string(env, NULL);
    debug_level = debug_flags_to_mask(str);
}

static acf_t
show_a_word(fcode_env_t *env, acf_t acf, void *arg)
{
    static int nshow_words = 0;

    if (acf == NULL) {
        if (nshow_words > 0) {
            log_message(MSG_DEBUG, "\n");
            nshow_words = 0;
        }
        return (NULL);
    }
    log_message(MSG_DEBUG, "%15s  ", get_name_or_acf(ACF_TO_LINK(acf)));
    nshow_words++;
    if (nshow_words >= 4) {
        log_message(MSG_DEBUG, "\n");
        nshow_words = 0;
    }
    return (NULL);
}

void
words(fcode_env_t *env)
{
    (void) search_all_dictionaries(env, show_a_word, NULL);
    (void) show_a_word(env, NULL, NULL);
}

static acf_t
dump_a_word(fcode_env_t *env, acf_t acf, void *arg)
{
    output_acf_name(acf);
    return (NULL);
}

void
dump_words(fcode_env_t *env)
{
    (void) search_all_dictionaries(env, dump_a_word, NULL);
    output_acf_name(NULL);
}

static void
dump_line(uchar_t *ptr)
{
    uchar_t *byte;
    int i;

    log_message(MSG_INFO, "%p  ", ptr);
    for (i = 0, byte = ptr; i < 16; i++) {
        if (i == 8)
            log_message(MSG_INFO, " ");
        log_message(MSG_INFO, "%02.2x ", *byte++);
    }
    log_message(MSG_INFO, " ");
    for (i = 0, byte = ptr; i < 16; i++, byte++) {
        log_message(MSG_INFO, "%c",
            ((*byte < 0x20) || (*byte > 0x7f)) ? '.' : *byte);
    }
    log_message(MSG_INFO, "\n");
}

void
dump_dictionary(fcode_env_t *env)
{
    uchar_t *ptr;

    log_message(MSG_INFO, "Dictionary dump: base: %p\n", env->base);
    for (ptr = (uchar_t *)(((long)(env->base)) & ~0xf); ptr < HERE;
        ptr += 16)
        dump_line(ptr);
}

static char *
acf_to_fcode_name(fcode_env_t *env, acf_t acf)
{
    int i;

    for (i = 0; i < MAX_FCODE; i++)
        if (env->table[i].apf == acf)
            return (env->table[i].name);
    return (NULL);
}

static acf_t
acf_match(fcode_env_t *env, acf_t sacf, void *macf)
{
    if (sacf == (acf_t)macf)
        return (sacf);
    return (NULL);
}

/*
 * Given an ACF, return ptr to name or "unknown" string.
 */
char *
acf_to_name(fcode_env_t *env, acf_t acf)
{
    struct bitab *bip;
    static char name_buf[256];
    uchar_t *p, *np;
    int i, n;

    if (!within_dictionary(env, acf)) {
        if ((bip = lookup_builtin((token_t)acf)) != NULL)
            return (bip->bi_name);
        return (NULL);
    }
    return (get_name_or_acf(ACF_TO_LINK(acf)));
}

int
within_dictionary(fcode_env_t *env, void *addr)
{
    return ((uchar_t *)addr >= env->base &&
        (uchar_t *)addr < env->base + dict_size);
}

static int
within_word(fcode_env_t *env, acf_t acf, acf_t wacf)
{
    if (acf == wacf || acf + 1 == wacf)
        return (1);
    if (*acf == (token_t)(&do_colon)) {
        do {
            if (acf == wacf)
                return (1);
        } while (*acf++ != (token_t)(&semi_ptr));
    }
    return (0);
}

/*
 * Given an ACF in the middle of a colon definition, search dictionary towards
 * beginning for "colon" acf.  If we find a "semi" acf first, we're not in
 * the middle of a colon-def (temporary execute?).
 */
char *
acf_backup_search(fcode_env_t *env, acf_t acf)
{
    acf_t nacf;
    char *name;

    if ((acf_t)_ALIGN(acf, token_t) == acf && within_dictionary(env, acf)) {
        for (nacf = acf; nacf >= (acf_t)env->base; nacf--)
            if (*nacf == (token_t)(&do_colon) ||
                *nacf == (token_t)(&semi_ptr))
                break;
        if (nacf >= (acf_t)env->base && *nacf == (token_t)(&do_colon) &&
            (name = get_name(ACF_TO_LINK(nacf))) != NULL)
            return (name);
    }
    return (acf_to_str(acf));
}

/*
 * Print out current process's C stack using /usr/proc/bin/pstack
 */
void
ctrace(fcode_env_t *env)
{
    char buf[256];
    FILE *fd;

    log_message(MSG_DEBUG, "Interpreter C Stack:\n");
    sprintf(buf, "/usr/proc/bin/pstack %d", getpid());
    if ((fd = popen(buf, "r")) == NULL)
        log_perror(MSG_ERROR, "Can't run: %s", buf);
    else {
        while (fgets(buf, sizeof (buf), fd))
            log_message(MSG_DEBUG, buf);
        (void) pclose(fd);
    }
}

/*
 * Dump data, return stacks, try to unthread forth calling stack.
 */
void
ftrace(fcode_env_t *env)
{
    log_message(MSG_DEBUG, "Forth Interpreter Stacks:\n");
    output_data_stack(env, MSG_DEBUG);
    output_return_stack(env, 1, MSG_DEBUG);
    log_message(MSG_DEBUG, "\n");
}

int in_forth_abort;

/*
 * Handle fatal error, if interactive mode, return to ok prompt.
 */
void
forth_abort(fcode_env_t *env, char *fmt, ...)
{
    va_list ap;
    char msg[256];

    if (in_forth_abort) {
        log_message(MSG_FATAL, "ABORT: abort within forth_abort\n");
        abort();
    }
    in_forth_abort++;

    va_start(ap, fmt);
    vsprintf(msg, fmt, ap);
    log_message(MSG_ERROR, "ABORT: %s\n", msg);

    if (env) {
        ctrace(env);
        ftrace(env);
    }

    return_to_interact(env);
    /*
     * If not in interactive mode, return_to_interact just returns.
     */
    exit(1);
}

/*
 * Handle fatal system call error
 */
void
forth_perror(fcode_env_t *env, char *fmt, ...)
{
    va_list ap;
    char msg[256];
    int save_errno = errno; /* just in case... */

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

    forth_abort(env, "%s: %s", msg, strerror(save_errno));
}

static void
show_stack(fcode_env_t *env)
{
#ifdef DEBUG
    debug_level ^= DEBUG_SHOW_STACK;
#else
    /*EMPTY*/
#endif
}

static void
print_bytes_header(int width, int offset)
{
    int i;

    for (i = 0; i < width; i++)
        log_message(MSG_INFO, " ");
    log_message(MSG_INFO, "  ");
    for (i = 0; i < 16; i++) {
        if (i == 8)
            log_message(MSG_INFO, " ");
        if (i == offset)
            log_message(MSG_INFO, "\\/ ");
        else
            log_message(MSG_INFO, "%2x ", i);
    }
    log_message(MSG_INFO, " ");
    for (i = 0; i < 16; i++) {
        if (i == offset)
            log_message(MSG_INFO, "v");
        else
            log_message(MSG_INFO, "%x", i);
    }
    log_message(MSG_INFO, "\n");
}

static void
dump(fcode_env_t *env)
{
    uchar_t *data;
    int len, offset;
    char buf[20];

    len = POP(DS);
    data = (uchar_t *)POP(DS);
    offset = ((long)data) & 0xf;
    len += offset;
    data = (uchar_t *)((long)data & ~0xf);
    sprintf(buf, "%p", data);
    print_bytes_header(strlen(buf), offset);
    for (len += offset; len > 0; len -= 16, data += 16)
        dump_line(data);
}

static acf_t
do_sifting(fcode_env_t *env, acf_t acf, void *pat)
{
    char *name;

    if ((name = get_name(ACF_TO_LINK(acf))) != NULL && strstr(name, pat))
        output_acf_name(acf);
    return (NULL);
}

static void
sifting(fcode_env_t *env)
{
    char *pat;

    if ((pat = parse_a_string(env, NULL)) != NULL) {
        (void) search_all_dictionaries(env, do_sifting, pat);
        output_acf_name(NULL);
    }
}

void
print_level(int level, int *doprint)
{
    int i;

    if (*doprint) {
        log_message(MSG_DEBUG, "\n    ");
        for (i = 0; i < level; i++)
            log_message(MSG_DEBUG, "    ");
        *doprint = 0;
    }
}

#define BI_QUOTE    1
#define BI_BLIT     2
#define BI_BDO      3
#define BI_QDO      4
#define BI_BR       5
#define BI_QBR      6
#define BI_BOF      7
#define BI_LOOP     8
#define BI_PLOOP    9
#define BI_TO       10
#define BI_SEMI     11
#define BI_COLON    12
#define BI_NOOP     13
#define BI_NOTYET   14  /* unimplented in "see" */

struct bitab bitab[] = {
    (token_t)(&quote_ptr),          "\"",       BI_QUOTE,
    (token_t)(&blit_ptr),           "blit",     BI_BLIT,
    (token_t)(&do_bdo_ptr),         "do",       BI_BDO,
    (token_t)(&do_bqdo_ptr),        "?do",      BI_QDO,
    (token_t)(&bbranch_ptrs[0]),        "br",       BI_BR,
    (token_t)(&bbranch_ptrs[1]),        "qbr",      BI_QBR,
    (token_t)(&bbranch_ptrs[2]),        "bof",      BI_BOF,
    (token_t)(&do_loop_ptr),        "loop",     BI_LOOP,
    (token_t)(&do_ploop_ptr),       "+loop",    BI_PLOOP,
    (token_t)(&to_ptr),         "to",       BI_NOOP,
    (token_t)(&semi_ptr),           ";",        BI_SEMI,
    (token_t)(&do_colon),           ":",        BI_COLON,
    (token_t)(&tlit_ptr),           "[']",      BI_NOOP,
    (token_t)(&do_leave_ptr),       "leave",    BI_NOTYET,
    (token_t)(&create_ptr),         "create",   BI_NOTYET,
    (token_t)(&does_ptr),           "does>",    BI_NOTYET,
    (token_t)(&value_defines[0][0]),    "a.@",      BI_NOTYET,
    (token_t)(&value_defines[0][1]),    "a.!",      BI_NOTYET,
    (token_t)(&value_defines[0][2]),    "a.nop",    BI_NOTYET,
    (token_t)(&value_defines[1][0]),    "a.i@",     BI_NOTYET,
    (token_t)(&value_defines[1][1]),    "a.i!",     BI_NOTYET,
    (token_t)(&value_defines[1][2]),    "a.iad",    BI_NOTYET,
    (token_t)(&value_defines[2][0]),    "a.defer",  BI_NOTYET,
    (token_t)(&value_defines[2][1]),    "a.@",      BI_NOTYET,
    (token_t)(&value_defines[2][2]),    "a.nop",    BI_NOTYET,
    (token_t)(&value_defines[3][0]),    "a.defexec",    BI_NOTYET,
    (token_t)(&value_defines[3][1]),    "a.iset",   BI_NOTYET,
    (token_t)(&value_defines[3][2]),    "a.iad",    BI_NOTYET,
    (token_t)(&value_defines[4][0]),    "a.binit",  BI_NOTYET,
    (token_t)(&value_defines[4][1]),    "a.2drop",  BI_NOTYET,
    (token_t)(&value_defines[4][2]),    "a.nop",    BI_NOTYET,
    (token_t)(&value_defines[5][0]),    "a.ibinit", BI_NOTYET,
    (token_t)(&value_defines[5][1]),    "a.2drop",  BI_NOTYET,
    (token_t)(&value_defines[5][2]),    "a.iad",    BI_NOTYET,
    0
};

struct bitab *
lookup_builtin(token_t builtin)
{
    int i;

    for (i = 0; bitab[i].bi_ptr; i++)
        if (bitab[i].bi_ptr == builtin)
            return (&bitab[i]);
    return (NULL);
}

static void
paren_see(fcode_env_t *env)
{
    acf_t save_acf = (acf_t)POP(DS);
    acf_t acf = save_acf;
    int i, n, pass;
    token_t brtab[30], thentab[30], brstk[30];
    int nbrtab = 0, nthentab = 0, nbrstk = 0;
    uchar_t *p;
    int level = 0, doprintlevel = 1, nthen;
    struct bitab *bip;
    token_t last_lit = 0, case_lit = 0, endof_loc = 0, endcase_loc = 0;

    if ((bip = lookup_builtin(*acf)) == NULL ||
        bip->bi_type != BI_COLON) {
        if (bip = lookup_builtin((token_t)acf))
            log_message(MSG_INFO, "%s: builtin\n", bip->bi_name);
        else
            log_message(MSG_INFO, "%s: builtin\n",
                acf_to_name(env, acf));
        return;
    }
    log_message(MSG_INFO, ": %s", acf_to_name(env, acf));
    for (pass = 0; pass < 2; pass++) {
        acf = save_acf;
        for (acf++; ; acf++) {
            if (pass) {
                print_level(level, &doprintlevel);
                for (nthen = 0; nthentab > 0 &&
                    thentab[nthentab-1] == (token_t)acf;
                    nthentab--)
                    nthen++;
                if (nthen) {
                    level -= nthen;
                    doprintlevel = 1;
                    print_level(level, &doprintlevel);
                    for (i = 0; i < nthen; i++)
                        log_message(MSG_INFO, "then ");
                }
                print_level(level, &doprintlevel);
                for (i = 0; i < nbrtab; i += 2)
                    if ((token_t)acf == brtab[i]) {
                        log_message(MSG_INFO, "begin ");
                        brstk[nbrstk++] = brtab[i+1];
                        level++;
                        doprintlevel = 1;
                    }
                print_level(level, &doprintlevel);
                if (case_lit == (token_t)acf) {
                    log_message(MSG_INFO, "case ");
                    doprintlevel = 1;
                    print_level(level, &doprintlevel);
                }
                if (endof_loc == (token_t)acf) {
                    log_message(MSG_INFO, "endof ");
                    doprintlevel = 1;
                    print_level(level, &doprintlevel);
                }
                if (endcase_loc == (token_t)acf) {
                    doprintlevel = 1;
                    print_level(level, &doprintlevel);
                    log_message(MSG_INFO, "endcase ");
                }
            }
            if ((bip = lookup_builtin((token_t)*acf)) == 0) {
                last_lit = (token_t)acf;
                if (pass)
                    log_message(MSG_INFO, "%s ",
                        acf_to_name(env, (acf_t)*acf));
                continue;
            }
            if (bip->bi_type == BI_SEMI) {
                if (pass) {
                    log_message(MSG_INFO, "\n");
                    log_message(MSG_INFO, "%s\n",
                        bip->bi_name);
                }
                break;
            }
            switch (bip->bi_type) {

            case BI_NOOP:
            case BI_NOTYET:
                if (pass)
                    log_message(MSG_INFO, "%s ",
                        bip->bi_name);
                break;

            case BI_QUOTE:
                if (pass)
                    log_message(MSG_INFO, "\" ");
                acf++;
                p = (uchar_t *)acf;
                n = *p++;
                if (pass)
                    log_message(MSG_INFO, "%s\" ", p);
                p += n + 1;
                for (; ((token_t)(p)) & (sizeof (token_t) - 1);
                    p++)
                    ;
                acf = (acf_t)p;
                acf--;
                break;

            case BI_BLIT:
                acf++;
                if (pass)
                    log_message(MSG_INFO, "%x ", *acf);
                break;

            case BI_BDO:
            case BI_QDO:
                if (pass) {
                    log_message(MSG_INFO, "%s ",
                        bip->bi_name);
                    doprintlevel = 1;
                    level++;
                }
                acf++;
                break;

            case BI_BR:
                acf++;
                if (pass) {
                    if (*acf < (token_t)acf) {
                        if (nbrstk) {
                            doprintlevel = 1;
                            level--;
                            print_level(level,
                                &doprintlevel);
                            log_message(MSG_INFO,
                                "repeat ");
                            nbrstk--;
                        } else
                            log_message(MSG_INFO,
                                "[br back?]");
                    } else if (nthentab) {
                        doprintlevel = 1;
                        print_level(level - 1,
                            &doprintlevel);
                        log_message(MSG_INFO, "else ");
                        doprintlevel = 1;
                        thentab[nthentab - 1] = *acf;
                    }
                } else {
                    if (*acf < (token_t)acf) {
                        brtab[nbrtab++] = *acf;
                        brtab[nbrtab++] = (token_t)acf;
                    }
                    if (endcase_loc == 0 &&
                        case_lit) {
                        endcase_loc = *acf;
                    }
                }
                break;

            case BI_QBR:
                acf++;
                if (pass) {
                    if (*acf < (token_t)acf) {
                        if (nbrstk) {
                            doprintlevel = 1;
                            level--;
                            print_level(level,
                                &doprintlevel);
                            log_message(MSG_INFO,
                                "until ");
                            nbrstk--;
                        } else
                            log_message(MSG_INFO,
                                "[br back?]");
                    } else if (nbrstk > 0 &&
                        *acf >= brstk[nbrstk - 1]) {
                        doprintlevel = 1;
                        print_level(level - 1,
                            &doprintlevel);
                        log_message(MSG_INFO,
                            "while ");
                        doprintlevel = 1;
                    } else {
                        log_message(MSG_INFO, "if ");
                        doprintlevel = 1;
                        level++;
                        thentab[nthentab++] = *acf;
                    }
                } else if (*acf < (token_t)acf) {
                    brtab[nbrtab++] = *acf;
                    brtab[nbrtab++] = (token_t)acf;
                }
                break;

            case BI_BOF:
                acf++;
                if (pass) {
                    log_message(MSG_INFO, "of ");
                    endof_loc = *acf;
                } else if (case_lit == 0) {
                    case_lit = last_lit;
                }
                break;

            case BI_LOOP:
            case BI_PLOOP:
                if (pass) {
                    level--;
                    doprintlevel = 1;
                    print_level(level, &doprintlevel);
                    log_message(MSG_INFO, "%s ",
                        bip->bi_name);
                }
                acf++;
                break;

            default:
                log_message(MSG_ERROR, "Invalid builtin %s\n",
                    bip->bi_name);
            }
        }
    }
}

static void
see(fcode_env_t *env)
{
    fstack_t d;

    parse_word(env);
    dollar_find(env);
    d = POP(DS);
    if (d)
        paren_see(env);
    else {
        log_message(MSG_WARN, "?");
        two_drop(env);
    }
}

static acf_t
do_dot_calls(fcode_env_t *env, acf_t acf, void *cacf)
{
    token_t *dptr = ACF_TO_LINK(acf);
    token_t *wptr = acf;

    if (*wptr == (token_t)(&do_colon)) {
        do {
            if ((acf_t)(*wptr) == (acf_t)cacf)
                output_acf_name(acf);
        } while (*wptr++ != (token_t)(&semi_ptr));
    } else if ((acf_t)(*wptr) == cacf)
        output_acf_name(acf);
    else if (wptr == (token_t *)cacf)
        output_acf_name(acf);
    return (NULL);
}

static void
dot_calls(fcode_env_t *env)
{
    acf_t acf = (acf_t)POP(DS);

    search_all_dictionaries(env, do_dot_calls, acf);
    output_acf_name(NULL);
}

static void
dot_pci_space(fcode_env_t *env)
{
    fstack_t d = POP(DS);

    switch ((d >> 24) & 0x3) {
    case 0: log_message(MSG_INFO, "Config,"); break;
    case 1: log_message(MSG_INFO, "IO,"); break;
    case 2: log_message(MSG_INFO, "Memory32,"); break;
    case 3: log_message(MSG_INFO, "Memory64,"); break;
    }
    if (d & 0x80000000)
        log_message(MSG_INFO, "Not_reloc,");
    if (d & 0x400000000)
        log_message(MSG_INFO, "Prefetch,");
    if (d & 0x200000000)
        log_message(MSG_INFO, "Alias,");
    log_message(MSG_INFO, "Bus%d,", (d >> 16) & 0xff);
    log_message(MSG_INFO, "Dev%d,", (d >> 11) & 0x1f);
    log_message(MSG_INFO, "Func%d,", (d >> 8) & 0x7);
    log_message(MSG_INFO, "Reg%x", d & 0xff);
    log_message(MSG_INFO, "\n");
}

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

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

static int mw_valid;
static int mw_size;
static void *mw_addr;
static fstack_t mw_value;
static fstack_t mw_lastvalue;

static fstack_t
mw_fetch(void)
{
    switch (mw_size) {
    case 1: return (*((uint8_t *)mw_addr));
    case 2: return (*((uint16_t *)mw_addr));
    case 4: return (*((uint32_t *)mw_addr));
    case 8: return (*((uint64_t *)mw_addr));
    }
    return (0);
}

void
do_memory_watch(fcode_env_t *env)
{
    fstack_t value;

    if (!mw_valid)
        return;
    value = mw_fetch();
    if (value != mw_lastvalue) {
        if (mw_valid == 1 || mw_value == value) {
            log_message(MSG_INFO,
                "memory-watch: %p/%d: %llx -> %llx\n",
                mw_addr, mw_size, (uint64_t)mw_lastvalue,
                (uint64_t)value);
            do_fclib_step(env);
        }
        mw_lastvalue = value;
    }
}

static void
set_memory_watch(fcode_env_t *env, int type, int size, void *addr,
    fstack_t value)
{
    switch (size) {
    case 1: case 2: case 4: case 8:
        break;
    default:
        log_message(MSG_ERROR, "set_memory_watch: invalid size: %d\n",
            size);
        return;
    }
    mw_valid = type;
    mw_size = size;
    mw_addr = addr;
    mw_value = value;
    mw_lastvalue = mw_fetch();
}

static void
memory_watch(fcode_env_t *env)
{
    int size = POP(DS);
    void *addr = (void *)POP(DS);

    set_memory_watch(env, 1, size, addr, 0);
}

static void
memory_watch_value(fcode_env_t *env)
{
    int size = POP(DS);
    void *addr = (void *)POP(DS);
    fstack_t value = POP(DS);

    set_memory_watch(env, 2, size, addr, value);
}

static void
memory_watch_clear(fcode_env_t *env)
{
    mw_valid = 0;
}

static void
vsearch(fcode_env_t *env)
{
    fstack_t value;
    int size = POP(DS);
    fstack_t match_value = POP(DS);
    uchar_t *toaddr = (uchar_t *)POP(DS);
    uchar_t *fromaddr = (uchar_t *)POP(DS);

    log_message(MSG_INFO, "%p to %p by %d looking for %llx\n", fromaddr,
        toaddr, size, (uint64_t)match_value);
    for (; fromaddr < toaddr; fromaddr += size) {
        switch (size) {
        case 1: value = *((uint8_t *)fromaddr); break;
        case 2: value = *((uint16_t *)fromaddr); break;
        case 4: value = *((uint32_t *)fromaddr); break;
        case 8: value = *((uint64_t *)fromaddr); break;
        default:
            log_message(MSG_INFO, "Invalid size: %d\n", size);
            return;
        }
        if (value == match_value)
            log_message(MSG_INFO, "%p\n", fromaddr);
    }
}

#pragma init(_init)

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

    ASSERT(env);
    NOTICE;

    FORTH(IMMEDIATE,    "words",        words);
    FORTH(IMMEDIATE,    "dump-words",       dump_words);
    FORTH(IMMEDIATE,    "dump-dict",        dump_dictionary);
    FORTH(IMMEDIATE,    "dump-table",       dump_table);
    FORTH(0,        "debugf",       debugf);
    FORTH(0,        ".debugf",      dot_debugf);
    FORTH(0,        "set-debugf",       set_debugf);
    FORTH(0,        "debugf?",      debugf_qmark);
    FORTH(0,        "control",      control);
    FORTH(0,        "dump",         dump);
    FORTH(IMMEDIATE,    "showstack",        show_stack);
    FORTH(IMMEDIATE,    "sifting",      sifting);
    FORTH(IMMEDIATE,    "ctrace",       ctrace);
    FORTH(IMMEDIATE,    "ftrace",       ftrace);
    FORTH(0,        "see",          see);
    FORTH(0,        "(see)",        paren_see);
    FORTH(0,        "base-addr",        base_addr);
    FORTH(0,        "smatch",       smatch);
    FORTH(0,        ".calls",       dot_calls);
    FORTH(0,        ".pci-space",       dot_pci_space);
    FORTH(0,        "(debug)",      paren_debug);
    FORTH(0,        "debug",        debug);
    FORTH(0,        ".debug",       dot_debug);
    FORTH(0,        "undebug",      undebug);
    FORTH(0,        "memory-watch",     memory_watch);
    FORTH(0,        "memory-watch-value",   memory_watch_value);
    FORTH(0,        "memory-watch-clear",   memory_watch_clear);
    FORTH(0,        "vsearch",      vsearch);
}