core.c

/* yForth? - Written by Luca Padovani (C) 1996/97
 * ------------------------------------------------------------------------
 * This software is FreeWare as long as it comes with this header in each
 * source file, anyway you can use it or any part of it whatever
 * you want. It comes without any warranty, so use it at your own risk.
 * ------------------------------------------------------------------------
 * Module name:     core.c
 * Abstract:        Core word set
 */

#include <string.h>
#include <setjmp.h>
#include <ctype.h>
#include <stdio.h>
#include <stdlib.h>
#include "yforth.h"
#include "udio.h"
#include "core.h"
#include "coree.h"
#include "float.h"
#include "double.h"
#include "toolse.h"
#include "locals.h"
#include "block.h"
#include "exceptio.h"

/**************************************************************************/
/* VARIABLES **************************************************************/
/**************************************************************************/

Char s_tmp_buffer[TMP_BUFFER_SIZE];     /* used by s" */

Cell _to_in;                            /* ptr to parse area */
Cell _source_id;                        /* input source device */
Char * _tib;                            /* ptr to terminal input buffer */
Char * _input_buffer;                   /* current input buffer */
Cell _in_input_buffer;                  /* # of chars in input buffer */
Cell _base;                             /* base is base */
Char * _dp;                             /* dictionary pointer */
Cell _error;                            /* error code */
struct word_def * _last;                /* ptr to last defined word */
Cell _state;                            /* state of the interpreter */
Cell _check_system = 1;                 /* 1 => check stacks overflow & underflow */
                                        /* Some variables used by environment? follows... */
Cell _env_slash_counted_string;         
Cell _env_slash_hold;
Cell _env_slash_pad;
Cell _env_address_unit_bits;
Cell _env_core;
Cell _env_core_ext;
Cell _env_floored;
Cell _env_max_char;
Cell _env_max_d;
Cell _env_max_n;
Cell _env_max_u;
Cell _env_max_ud;
Cell _env_return_stack_cells;
Cell _env_stack_cells;
Cell _env_double;
Cell _env_double_ext;
Cell _env_floating;
Cell _env_floating_stack;
Cell _env_max_float;
Cell _env_floating_ext;
Cell _env_memory_alloc;
Cell _env_memory_alloc_ext;
Cell _env_search_order;
Cell _env_search_order_ext;
Cell _env_wordlists;
Cell _env_tools;
Cell _env_tools_ext;
Cell _env_number_locals;
Cell _env_locals;
Cell _env_locals_ext;
Cell _env_facility;
Cell _env_facility_ext;
Cell _env_block;
Cell _env_block_ext;
Cell _env_exception;
Cell _env_exception_ext;
Cell _env_file;
Cell _env_file_ext;
Cell _env_string;
Cell _env_string_ext;

/**************************************************************************/
/* WORDS ******************************************************************/
/**************************************************************************/

void _dot_quote() {
      compile_cell((Cell) _paren_dot_quote_paren);
      *--sp = '"';
      _word();
      _dp = (Char *) WORD_PTR(_dp);
    sp++;
}

void _paren_dot_quote_paren() {
    register Char *addr = (Char *) ip;
    *--sp = (Cell) (addr + 1);
    *--sp = (Cell) *addr;
      _type();
      ip = (pfp *) WORD_PTR((Char *) ip);
}

void _type() {
    register Cell u = *sp++;
    register Char *addr = (Char *) *sp++;
    while (u--) putchar(*addr++);
}

void _u_dot() {
      *--sp = 0;
    _less_number_sign();
    _number_sign_s();
    _number_sign_greater();
      _type();
    putchar(' ');
}

void _c_r() {
      putchar('\n');
}

void _emit() {
      putchar(*sp++);
}

#ifdef DOUBLE_DEF
void _dot() {
      _s_to_d();
      _d_dot();
}
#else
void _dot() {
      register DCell u = *sp;
      register int usign = u < 0;
      if (usign) u = -u;
      sp--;
      PUT_DCELL(sp, u);
      _less_number_sign();
      _number_sign_s();
      if (usign) {
            *--sp = '-';
            _hold();
      }
      _number_sign_greater();
      _type();
      putchar(' ');
}
#endif

void _space() {
    putchar(' ');
}

void _spaces() {
    register UCell u = *sp++;
    while (u--) putchar(' ');
}

void _less_number_sign() {
      in_pnos = 0;
      p_pnos = pnos + pnos_size;
}

void _number_sign() {
      register UDCell ud1 = GET_DCELL(sp);
      register int rem = ud1 % _base;
      ud1 /= _base;
      PUT_DCELL(sp, ud1);
      if (rem < 10) *--p_pnos = rem + '0';
      else *--p_pnos = rem - 10 + 'a';
      in_pnos++;
}

void _hold() {
      register Char ch = (Char) *sp++;
      *--p_pnos = ch;
      in_pnos++;
}

void _number_sign_s() {
      do _number_sign();
      while (sp[0] || sp[1]);
}

void _number_sign_greater() {
      sp[1] = (Cell) p_pnos;
      sp[0] = in_pnos;
}

void _store() {
      register Cell *addr = (Cell *) *sp++;
      *addr = *sp++;
}

void _star() {
    sp[1] *= *sp;
    sp++;
}

void _star_slash() {
    register DCell d = (DCell) sp[1] * (DCell) sp[2];
    sp[2] = d / (DCell) sp[0];
    sp += 2;
}

void _star_slash_mod() {
      register DCell d = (DCell) sp[1] * (DCell) sp[2];
    sp[2] = d % (DCell) sp[0];
      sp[1] = d / (DCell) sp[0];
      sp++;
}

void _plus() {
      sp[1] += sp[0];
      sp++;
}

void _plus_store() {
    register Cell *addr = (Cell *) *sp++;
    *addr += *sp++;
}

void _minus() {
    sp[1] -= sp[0];
    sp++;
}

void _slash() {
      sp[1] /= sp[0];
      sp++;
}

void _slash_mod() {
      register Cell n1 = sp[1];
      register Cell n2 = sp[0];
    sp[1] = n1 % n2;
    sp[0] = n1 / n2;
}

void _zero_less() {
    sp[0] = FFLAG(sp[0] < 0);
}

void _zero_equals() {
    sp[0] = FFLAG(sp[0] == 0);
}

void _one_plus() {
      sp[0]++;
}

void _one_minus() {
    sp[0]--;
}

void _two_store() {
    register Cell *addr = (Cell *) *sp++;
    *addr++ = *sp++;
    *addr = *sp++;
}

void _two_star() {
    sp[0] <<= 1;
}

void _two_slash() {
      sp[0] >>= 1;
}

void _two_fetch() {
    register Cell *addr = (Cell *) *sp;
    *sp-- = *(addr + 1);
    *sp = *addr;
}

void _two_drop() {
    sp += 2;
}

void _two_dupe() {
    sp -= 2;
    sp[0] = sp[2];
    sp[1] = sp[3];
}

void _two_over() {
      sp -= 2;
    sp[0] = sp[4];
    sp[1] = sp[5];
}

void _two_swap() {
    register Cell x4 = sp[0];
      register Cell x3 = sp[1];
      sp[0] = sp[2];
    sp[1] = sp[3];
    sp[2] = x4;
    sp[3] = x3;
}

void _less_than() {
    sp[1] = FFLAG(sp[1] < sp[0]);
    sp++;
}

void _equals() {
      sp[1] = FFLAG(sp[1] == sp[0]);
    sp++;
}

void _greater_than() {
    sp[1] = FFLAG(sp[1] > sp[0]);
    sp++;
}

void _to_r() {
    *--rp = *sp++;
}

void _question_dupe() {
    if (sp[0]) sp--, sp[0] = sp[1];
}

void _fetch() {
    sp[0] = *((Cell *) sp[0]);
}

void _abs() {
    register Cell n = sp[0];
    sp[0] = n >= 0 ? n : -n;
}

void _align() {
      _dp = (Char *) ALIGN_PTR(_dp);
}

void _aligned() {
    sp[0] = ALIGN_PTR((Cell *) sp[0]);
}

void _and() {
      sp[1] &= sp[0];
    sp++;
}

void _b_l() {
      *--sp = ' ';
}

void _c_store() {
    register Char *addr = (Char *) *sp++;
    *addr = (Char) *sp++;
}

void _c_fetch() {
    register Char *addr = (Char *) *sp;
    *sp = (Cell) *addr;
}

void _cell_plus() {
      sp[0] += sizeof(Cell);
}

void _cells() {
    sp[0] *= sizeof(Cell);
}

void _char_plus() {
    sp[0] += sizeof(Char);
}

void _chars() {
    sp[0] *= sizeof(Char);
}

void _depth() {
      register Cell dep = sp_top - sp;
      *--sp = dep;
}

void _drop() {
      sp++;
}

void _dupe() {
    sp--;
    sp[0] = sp[1];
}

void _f_m_slash_mod() {
    register Cell n1 = *sp++;
      register DCell d1 = GET_DCELL(sp);
    sp[0] = d1 / n1;
    sp[1] = d1 % n1;
#if !FLOORED_DIVISION
      if (*sp < 0) {
            sp[0]--;
            if (sp[1] > 0) sp[1]++;
            else sp[1]--;
            sp[1] = -sp[1];
      }     
#endif
}

void _invert() {
    sp[0] = ~sp[0];
}

void _l_shift() {
      register UCell u = (UCell) *sp++;
    sp[0] <<= u;
}

void _m_star() {
    register DCell d = (DCell) sp[1] * (DCell) sp[0];
      PUT_DCELL(sp, d);
}

void _max() {
    register Cell n2 = *sp++;
    sp[0] = sp[0] > n2 ? sp[0] : n2;
}

void _min() {
    register Cell n2 = *sp++;
    sp[0] = sp[0] < n2 ? sp[0] : n2;
}

void _mod() {
    sp[1] %= sp[0];
    sp++;
}

void _negate() {
    sp[0] = -sp[0];
}

void _or() {
      sp[1] |= sp[0];
    sp++;
}

void _over() {
    sp--;
    sp[0] = sp[2];
}

void _r_from() {
      *--sp = *rp++;
}

void _r_fetch() {
    *--sp = *rp;
}

void _rote() {
    register Cell x3 = sp[0];
    register Cell x2 = sp[1];
    register Cell x1 = sp[2];
    sp[0] = x1;
    sp[1] = x3;
    sp[2] = x2;
}

void _r_shift() {
    register UCell u = (UCell) *sp++;
      ((UCell *) sp)[0] >>= u;
}

void _s_to_d() {
    register DCell d = (DCell) (*sp--);
      PUT_DCELL(sp, d);
}

void _s_m_slash_rem() {
    register Cell n1 = *sp++;
      register DCell d1 = GET_DCELL(sp);
    sp[0] = d1 / n1;
    sp[1] = d1 % n1;
#if FLOORED_DIVISION
      if (*sp < 0) {
            sp[0]++;
            if (sp[1] > 0) sp[1]--;
            else sp[1]++;
            sp[1] = -sp[1];
      }     
#endif
}

void _swap() {
    register Cell temp = sp[0];
    sp[0] = sp[1];
    sp[1] = temp;
}

void _u_less_than() {
    sp[1] = FFLAG((UCell) sp[1] < (UCell) sp[0]);
      sp++;
}

void _u_m_star() {
      register UDCell ud = (UDCell) sp[1] * (UDCell) sp[0];
      PUT_DCELL(sp, ud);
}

void _u_m_slash_mod() {
      register UCell u1 = *sp++;
      register UDCell ud = GET_DCELL(sp);
      sp[1] = ud % u1;
      sp[0] = ud / u1;
}

void _xor() {
      sp[1] ^= sp[0];
      sp++;
}

void _do_literal() {
    *--sp = (Cell) *ip++;
}

void _do_fliteral() {
      *--fp = (Real) *((Real *) ip);
      ip += sizeof(Real) / sizeof(Cell);
}

void _word() {
      register Char *addr;
      register Char delim = (Char) *sp;
      register int i, j;
      while (_to_in < _in_input_buffer && _input_buffer[_to_in] == delim) _to_in++;
      _parse();
      i = *_dp = *sp++;
      addr = (Char *) *sp;
      for (j = 0; j < i; j++) *(_dp + j + 1) = *addr++;
      *(_dp + i + 1) = ' ';
      *sp = (Cell) _dp;
}

void _to_number() {
      register UCell u1 = (UCell) *sp;
    register Char *addr = (Char *) *(sp + 1);
      register UDCell ud1 = GET_DCELL(sp + 2);
      while (is_base_digit(*addr) && u1) {
            ud1 *= _base;
            if (*addr <= '9') ud1 += *addr - '0';
            else ud1 += toupper(*addr) - 'A' + 10;
            addr++;
            u1--;
      }
      PUT_DCELL(sp + 2, ud1);
      *(sp + 1) = (Cell) addr;
      *sp = u1;
}

void _read_const() {
      register Cell n;
      register Cell usign = 1;
      register UDCell num;
      register const_type = 1;
      register Char *orig = (Char *) sp[1];
      register Cell orig_len = sp[0];
      if (sp[0] && *((Char *) sp[1]) == '-') {
            usign = -1;
            sp[1] += sizeof(Char);
            sp[0]--;
      }
      while (sp[0]) {
            _to_number();
            if (sp[0] && *((Char *) sp[1]) == '.') {
                  const_type = 2;
                  sp[0]--;
                  sp[1] += sizeof(Char);
            } else break;
      }
      n = *sp++;
      num = GET_DCELL(sp + 1);
      if (usign < 0) {
            num = -num;
            PUT_DCELL(sp + 1, num);
      }
      if (!n) *sp = const_type;
#ifdef FLOAT_DEF
      else {
            if (_base == 10) {
                  sp++;
                  sp[1] = (Cell) orig;
                  sp[0] = orig_len;
                  _to_float();
                  if (*sp) sp[0] = 3;
            } else *sp = 0;
      }
#else
      else *sp = 0;
#endif
}

void _interpret() {
      register struct word_def *xt;
      while (!_error && _to_in < _in_input_buffer) {
            *--sp = ' ';
            _word();
            sp++;
            if (!(*_dp)) continue;                    /* Please forget this! */
            xt = search_word(_dp + 1, *_dp);
            if (xt) {
                  if (_state == INTERPRET) {
                        if (xt->class & COMP_ONLY) _error = E_NOCOMP;
                        else exec_word(xt);
                  } else /* _state == COMPILE */ {
                        if (xt->class & IMMEDIATE) exec_word(xt);
                        else compile_word(xt);
                  }
            } else /* xt == 0 */ {
                  register UDCell num;
                  *--sp = 0;
                  *--sp = 0;
                  *--sp = (Cell) (_dp + sizeof(Char));
                  *--sp = (Cell) *_dp;
                  _read_const();
                  if (!(*sp)) {
                        sp++;
                        _error = E_NOWORD;
                  } else {
                        switch (*sp++) {
                              case 1:
                                    num = GET_DCELL(sp);
                                    if (_state == INTERPRET) sp++;
                                    else {
                                          sp += 2;
                                          compile_cell((Cell) _do_literal);
                                          compile_cell((Cell) num);
                                    }
                                    break;
                              case 2:
                                    num = GET_DCELL(sp);
                                    if (_state == COMPILE) {
                                          sp += 2;
                                          compile_cell((Cell) _do_literal);
                                          compile_cell((Cell) num);
                                          compile_cell((Cell) _do_literal);
                                          compile_cell((Cell) (num >> CellBits));
                                    }
                                    break;
                              case 3:
                                    if (_state == COMPILE) {
                                          compile_cell((Cell) _do_fliteral);
                                          compile_real(*fp);
                                          fp++;
                                    }
                                    break;
                        }
                  }
            }
      }
}

void _accept() {
    register Cell n1 = *sp++;
    register Char *addr = (Char *) *sp;
      register int i = 0;
    register char ch;
    do {
            ch = getchar();
        i = process_char(addr, n1, i, ch);
    } while (ch != '\n');
    *sp = i;
}

void _source() {
    *--sp = (Cell) _input_buffer;
    *--sp = _in_input_buffer;
}

void _paren() {
      register Cell eof = 1;
      do {
            while (_to_in < _in_input_buffer && _input_buffer[_to_in] != ')') _to_in++;
            if (_source_id != 0 && _source_id != -1 && _to_in == _in_input_buffer) {
                  _refill();
                  eof = !(*sp++);
            }
      } while (_to_in == _in_input_buffer && !eof);
      if (_to_in < _in_input_buffer) _to_in++;
}

void _evaluate() {
    register Cell u = *sp++;
      register Char *addr = (Char *) *sp++;
      save_input_specification();
      _source_id = -1;
      _in_input_buffer = u;
      _input_buffer = addr;
      _to_in = 0;
      _b_l_k = 0;
      _interpret();
      restore_input_specification();
}

void _view_error_msg() {
      static struct an_error {
            char *msg;
            char please_abort;
            char print_word;
      } err_msg[] = {
            { "everything allright",                        0, 0 },
            { "no input avaliable",                         0, 0 },
            { "unknown word",                               0, 1 },
            { "word must be compiled",                      0, 1 },
            { "corrupted dictionary",                       1, 0 },
            { "not enough memory",                          0, 0 },
            { "data-stack underflow",                       1, 0 },
            { "data-stack overflow",                        1, 0 },
            { "return-stack underflow",                     1, 0 },
            { "return-stack overflow",                      1, 0 },
            { "floating-stack underflow",             1, 0 },
            { "floating-stack overflow",              1, 0 },
            { "data-space corrupted",                       1, 0 },
            { "data-space exhausted",                       1, 0 },
            { "unable to access image file",          0, 0 },
            { "primitive not implemented",          0, 1 },
            { "floating-point/math exception",        0, 0 },
            { "segmentation fault",                         0, 0 },
            { "file not found",                                   0, 0 },
      };
      if (err_msg[-_error].print_word) {
            putchar('[');
            *--sp = (Cell) _dp;
            _count();
            _type();
            printf("] ");
      }
      printf("error(%d): %s.\n", -_error, err_msg[-_error].msg);
      if (err_msg[-_error].please_abort) {
            printf("Aborting...\n");
            _abort();
      }
}

void _quit() {
      while (1) {
            rp = rp_top;
            _source_id = 0;
            _input_buffer = _tib;
            _state = INTERPRET;
            _error = E_OK;
            while (_error == E_OK) {
                  _refill();
                  if (*sp++) {
                        _to_in = 0;
                        _interpret();
                        if (_state == INTERPRET && !_error) printf("ok\n");
                        else if (_state == COMPILE) printf("ko ");
                  } else _error = E_NOINPUT;
                  if (_error == E_OK && _check_system) check_system();
            }
            _view_error_msg();
      }
}

void _comma() {
      *((Cell *) _dp) = *sp++;
      _dp += sizeof(Cell);
}

void _allot() {
      _dp += *sp++;
}

void _c_comma() {
      *_dp++ = (Char) *sp++;
}

void _here() {
    *--sp = (Cell) _dp;
}

void _do_exit() {
      ip = 0;
}

void _exit_imm() {
      clear_locals();
      compile_cell((Cell) _do_exit);
}

void _paren_do_colon_paren() {
      *--rp = (Cell) (ip + 1);
      ip = (pfp *) *ip;
      while (ip) (*ip++)();
      ip = (pfp *) *rp++;
}

void _colon() {
      create_definition(A_COLON);
      _state = COMPILE;
      init_locals();
}

void _variable() {
      create_definition(A_VARIABLE);
      compile_cell(0);
      mark_word(_last);
}

void _constant() {
      register Cell x = *sp++;
      create_definition(A_CONSTANT);
      compile_cell(x);
      mark_word(_last);
}

void _create() {
      create_definition(A_CREATE);
      compile_cell(0);
      mark_word(_last);
}

void _does() {
      compile_cell((Cell) _paren_does_paren);
      _exit_imm();
      mark_word(_last);
      init_locals();
}

void _paren_does_paren() {
      _last->func[0] = (pfp) (ip + 1);
}

void _semi_colon() {
      _exit_imm();
      _state = INTERPRET;
      mark_word(_last);
}

void _zero_branch() {
      if (*sp++) ip++;
      else ip += 1 + (Cell) *ip;
}

void _branch() {
      ip += 1 + (Cell) *ip;
}

void _if() {
      compile_cell((Cell) _zero_branch);
      *--sp = (Cell) _dp;
      compile_cell(0);
}

void _then() {
    register Cell *patch = (Cell *) *sp++;
    *patch = ((Cell *) _dp) - patch - 1;
}

void _else() {
      _ahead();
      *--sp = 1;
      _roll();
      _then();
}

void _begin() {
    *--sp = (Cell) _dp;
}

void _do() {
    compile_cell((Cell) _paren_do_paren);
    *--sp = (Cell) _dp;
    *--sp = 0;  /* Non e' un ?do */
}

void _paren_do_paren() {
    *--rp = *sp++;
    *--rp = *sp++;
    /* R: index limit --- */
}

void _loop() {
    register Cell q_do = *sp++;
    register Cell *dest = (Cell *) *sp++;
    compile_cell((Cell) _paren_loop_paren);
    compile_cell(dest - ((Cell *) _dp) - 1);
    if (q_do) {
        register Cell *patch = (Cell *) *sp++;
        *patch = ((Cell *) _dp) - patch - 1;
    }
}

void _paren_loop_paren() {
    if (rp[0] == ++rp[1]) {
        ip++;
        rp += 2;
    } else ip += 1 + (Cell) *ip;
}

void _i() {
    *--sp = rp[1];
}

void _j() {
    *--sp = rp[3];
}

void _plus_loop() {
    register Cell q_do = *sp++;
    register Cell *dest = (Cell *) *sp++;
    compile_cell((Cell) _paren_plus_loop_paren);
    compile_cell(dest - ((Cell *) _dp) - 1);
    if (q_do) {
        register Cell *patch = (Cell *) *sp++;
        *patch = ((Cell *) _dp) - patch - 1;
    }
}

void _paren_plus_loop_paren() {
    register Cell old_index = *rp;
    rp[1] += *sp++;
    if (old_index < rp[1] && rp[0] >= rp[1]) {
        ip++;
        rp += 2;
    } else ip += 1 + (Cell) *ip;
}

void _find() {
      register Char *addr = (Char *) *sp;
      register Cell len = (Cell) *addr++;
      register struct word_def *xt = search_word(addr, len);
      set_find_stack(addr, xt);
}

void _recurse() {
    compile_cell((Cell) _paren_do_colon_paren);
    compile_cell((Cell) &_last->func[0]);
}

void _tick() {
    register Char *addr;
    *--sp = ' ';
      _word();
      addr = (Char *) *sp;
      if (!(*sp = (Cell) search_word(addr + 1, *addr))) _error = E_NOWORD;
}

void _to_body() {
      *sp = (Cell) &((struct word_def *) *sp)->func[0];
}

void _abort() {
      *--sp = -1;
      _throw();
}

void _abort_quote() {
      _if();
      _s_quote();
      compile_cell((Cell) _do_literal);
      compile_cell(-2);
      compile_cell((Cell) _throw);
      _then();
}

void _count() {
      register Char *addr = (Char *) *sp;
    sp--;
    sp[0] = (Cell) *addr;
    sp[1]++;
}

void _decimal() {
    _base = 10;
}

void _environment_query() {
      register Cell len = *sp++;
      register Char *addr = (Char *) *sp++;
      static struct {
            Char *name;
            Cell *var;
      } kw[] = {
            { "/COUNTED-STRING",          &_env_slash_counted_string },
            { "/HOLD",                          &_env_slash_hold },
            { "/PAD",                           &_env_slash_pad },
            { "ADDRESS-UNIT-BITS",        &_env_address_unit_bits },
            { "CORE",                           &_env_core },
            { "CORE-EXT",                       &_env_core_ext },
            { "FLOORED",                        &_env_floored },
            { "MAX-CHAR",                       &_env_max_char },
            { "MAX-D",                          &_env_max_d },
            { "MAX-N",                          &_env_max_n },
            { "MAX-U",                          &_env_max_u },
            { "MAX-UD",                         &_env_max_ud },
            { "RETURN-STACK-CELLS",       &_env_return_stack_cells },
            { "STACK-CELLS",              &_env_stack_cells },
            { "DOUBLE",                         &_env_double },
            { "DOUBLE-EXT",                     &_env_double_ext },
            { "FLOATING",                       &_env_floating },
            { "FLOATING-STACK",                 &_env_floating_stack },
            { "MAX-FLOAT",                      &_env_max_float },
            { "FLOATING-EXT",             &_env_floating_ext },
            { "MEMORY-ALLOC",             &_env_memory_alloc },
            { "MEMORY-ALLOC-EXT",         &_env_memory_alloc_ext },
            { "SEARCH-ORDER",             &_env_search_order },
            { "WORDLISTS",                      &_env_wordlists },
            { "SEARCH-ORDER-EXT",         &_env_search_order_ext },
            { "TOOLS",                          &_env_tools },
            { "TOOLS-EXT",                      &_env_tools_ext },
            { "#LOCALS",                        &_env_number_locals },
            { "LOCALS",                         &_env_locals },
            { "LOCALS-EXT",                     &_env_locals_ext },
            { "FACILITY",                       &_env_facility },
            { "FACILITY-EXT",             &_env_facility_ext },
            { "BLOCK",                          &_env_block },
            { "BLOCK-EXT",                      &_env_block_ext },
            { "EXCEPTION",                      &_env_exception },
            { "EXCEPTION-EXT",                  &_env_exception_ext },
            { "FILE",                           &_env_file },
            { "FILE-EXT",                       &_env_file_ext },
            { "STRING",                         &_env_string },
            { "STRING-EXT",                     &_env_string_ext },
            { NULL,                             NULL },
      };
      register int i = 0;
      for (i = 0; i < len; i++) addr[i] = toupper(addr[i]);
      i = 0;
      while (kw[i].name && memcmp(addr, kw[i].name, len)) i++;
      if (kw[i].name) {
            if (!strcmp(kw[i].name + 1, "MAX-UD")) {
                  sp -= 2;
                  PUT_DCELL(sp, MAX_UD);
            } else if (!strcmp(kw[i].name + 1, "MAX-FLOAT"))
                  *--fp = MAX_F;
            else *--sp = *kw[i].var;
            *--sp = FFLAG(1);
      } else *--sp = FFLAG(0);
}

void _execute() {
      exec_word((struct word_def *) *sp++);
}

void _fill() {
      register int c = (int) *sp++;
      register UCell u = (UCell) *sp++;
      register Char *addr = (Char *) *sp++;
      if (u) memset(addr, c, u);
}

void _immediate() {
    _last->class |= IMMEDIATE;
}

void _key() {
      *--sp = d_getch();
}

void _leave() {
    rp += 2;
      while (*ip != _paren_loop_paren && *ip != _paren_plus_loop_paren) ip++;
    ip += 2;
}

void _literal() {
    compile_cell((Cell) _do_literal);
    compile_cell(sp[0]);
    sp++;
}

void _move() {
    register UCell u = (UCell) *sp++;
    register Char *dest = (Char *) *sp++;
    register Char *source = (Char *) *sp++;
    if (u) memmove(dest, source, u);
}

void _postpone() {
    *--sp = ' ';
    _word();
    _find();
    if (*sp++ > 0)  /* IMMEDIATE word */
        compile_word((struct word_def *) *sp++);
    else {
        compile_cell((Cell) _paren_compile_paren);
        compile_cell(sp[0]);
        sp++;
    }
}

void _paren_compile_paren() {
    compile_word((struct word_def *) *sp++);
}

void _s_quote() {
      if (_state == INTERPRET) {
            *--sp = '"';
            _word();
            memcpy(s_tmp_buffer, _dp, *_dp + 1);
            sp[0] = (Cell) s_tmp_buffer;
            _count();
      } else {
            _c_quote();
            compile_cell((Cell) _count);
      }
}

void _sign() {
    if (*sp++ < 0) {
            *p_pnos-- = '-';
            in_pnos++;
    }
}

void _unloop() {
    rp += 2;
}

void _left_bracket() {
    _state = INTERPRET;
}

void _bracket_tick() {
    _tick();
    _literal();
}

void _char() {
      *--sp = ' ';
      _word();
      sp[0] = _dp[1];
}

void _bracket_char() {
      _char();
      _literal();
}

void _right_bracket() {
    _state = COMPILE;
}

void _while() {
      _if();
      *--sp = 1;
      _roll();
}

void _repeat() {
      _again();
      _then();
}

void _do_value() {
      *--sp = (Cell) *((Cell *) *ip++);
}

/**************************************************************************/
/* AUXILIARY FUNCTIONS ****************************************************/
/**************************************************************************/

/* strmatch: compare two strings, the first is expressed as (s1, len), while
 * the second is a counted string pointed by "s2". If the two strings are
 * identical return 0, 1 otherwise. The comparison is case INsensitive
 */
int strmatch(const Char *s1, const Char *s2, int len1) {
      if (len1 != *s2++) return (1);
      else {
            while (len1--) if (toupper(*s1++) != toupper(*s2++)) return (1);
            return (0);
      }
}

/* search_wordlist: search a word (name, len) within the selected vocabulary.
 * Called by "search_word"
 */
struct word_def *search_wordlist(Char *name, Cell len, struct vocabulary *wid) {
      register struct word_def *p = wid->voc[hash_func(name, len)];
      while (p && strmatch(name, p->name, len)) p = p->link;
      return (p);
}

/* search_word: search the word (name, len) into the vocabularies, starting
 * with the vocabulary on the top of the vocabularies stack. If found,
 * return the word's execution token, which is a pointer to the structure
 * "word_def" of the word. If not found, return NULL.
 */
struct word_def *search_word(Char *name, Cell len) {
      register struct word_def *p;
      register Cell ttop = top;
      if (locals_defined()) {
            p = get_first_local();
            while (p && strmatch(name, p->name, len)) p = p->link;
            if (p) return (p);
      }
      while (ttop >= 0) {
            p = search_wordlist(name, len, ttop >= 0 ? list[ttop] : forth_wid);
            if (p) return (p);
            ttop--;
      }
      return (0);
}

/* ins_word: add the word with execution token "p" in the current
 * compilation vocabulary
 */
void ins_word(struct word_def *p) {
      register int hash = hash_func(p->name + 1, *p->name);
      p->link = voc->voc[hash];
}

/* mark_word: make the word with execution token "p" visible, by updating
 * the compilation vocabulary head pointer
 */
void mark_word(struct word_def *p) {
      register int hash = hash_func(p->name + 1, *p->name);
      voc->voc[hash] = p;
}

/* set_find_stack: setup the data stack after a search in the vocabularies
 * as reuired by the word "find"
 */
void set_find_stack(Char *addr, struct word_def *xt) {
      if (xt) {
            *sp = (Cell) xt;
            if (xt->class & IMMEDIATE) *--sp = 1;
            else *--sp = (Cell) -1;
      } else {
            *sp = (Cell) addr;
            *--sp = 0;
      }
}

/* is_base_digit: return true if the digit "ch" is valid in the current base
 * stored in the variable "base".
 */
int is_base_digit(Char ch) {
      ch = toupper(ch);
      if (ch >= '0' && ch <= '9') {
            if (ch - '0' < _base) return (1);
            else return (0);
      }
      if (ch >= 'A' && ch <= 'Z') {
            if (ch - 'A' + 10 < _base) return (1);
            else return (0);
      }
      return (0);
}

/* process_char: do the work when a key is stroken on the keyboard.
 * "addr" is a base pointer to the buffer where the characters are to be
 * stored, "max_len" is the size of the buffer, "cur_pos" the current
 * position within the buffer, and "ch" the character to be processed.
 */
int process_char(Char *addr, int max_len, int cur_pos, char ch) {
      switch (ch) {
            case '\b':
                  if (cur_pos) cur_pos--;
                  else putchar('\a');
                  break;
            case 0:
        case EOF:
        default:
            if (ch >= 32) {
                        if (cur_pos < max_len) addr[cur_pos++] = ch;
                        else putchar('\a');
            }
                  break;
      }
      return cur_pos;
}

/* create_definition: create a new word in the dictionary allocating the
 * space for the name, which is stored yet by the call to "word", then
 * allocating a structure "word_def" and setting the "class" field to the
 * value passed to the function.
 */
void create_definition(Cell class) {
      register struct word_def *def;
      register Char *name;
      *--sp = (Cell) ' ';
      name = _dp;
      _word();
      sp++;
      _dp = (Char *) WORD_PTR(_dp);
      _align();
      def = (struct word_def *) _dp;
      _last = def;
      def->name = name;
      def->class = class;
      ins_word(def);
      _dp += sizeof(struct word_def) - sizeof(Cell);
}

/* exec_colon: execute a colon definition, with the first instruction pointed
 * by "ip0"
 */
void exec_colon(pfp *ip0) {
      register pfp *old_ip = ip;
      ip = ip0;
      while (ip) (*ip++)();
      ip = old_ip;
}

/* exec_word: execute the word with execution token "xt" when interpreting
 */
void exec_word(struct word_def *xt) {
      switch (xt->class & A_WORD) {
            case A_PRIMITIVE: xt->func[0](); break;
            case A_FVARIABLE:
            case A_2VARIABLE:
            case A_VARIABLE: *--sp = (Cell) &xt->func[0]; break;
            case A_COLON: exec_colon(&xt->func[0]); break;
            case A_VALUE:
            case A_USER:
            case A_CONSTANT: *--sp = (Cell) xt->func[0]; break;
            case A_2CONSTANT:
                  *--sp = (Cell) xt->func[0];
                  *--sp = (Cell) xt->func[1];
                  break;
            case A_FCONSTANT: *--fp = *((Real *) &xt->func[0]); break;
            case A_CREATE:
                  *--sp = (Cell) &xt->func[1];
                  if (xt->func[0]) exec_colon((pfp *) xt->func[0]);
                  break;
            case A_MARKER:
                  exec_marker((struct voc_marker *) &xt->func[0]);
                  break;
            case A_LOCAL:
            default: _error = E_NOVOC; break;
      }
}

/* compile_word: compile word with execution token "xt" within the dictionary
 */
void compile_word(struct word_def *xt) {
      switch (xt->class & A_WORD) {
            case A_PRIMITIVE:
                  compile_cell((Cell) xt->func[0]);
                  break;
            case A_VARIABLE:
            case A_2VARIABLE:
            case A_FVARIABLE:
                  compile_cell((Cell) _do_literal);
                  compile_cell((Cell) &xt->func[0]);
                  break;
            case A_VALUE:
                  compile_cell((Cell) _do_value);
                  compile_cell((Cell) &xt->func[0]);
                  break;
            case A_USER:
            case A_CONSTANT:
                  compile_cell((Cell) _do_literal);
                  compile_cell((Cell) xt->func[0]);
                  break;
            case A_2CONSTANT:
                  compile_cell((Cell) _do_literal);
                  compile_cell((Cell) xt->func[0]);
                  compile_cell((Cell) _do_literal);
                  compile_cell((Cell) xt->func[1]);
                  break;
            case A_FCONSTANT:
                  compile_cell((Cell) _do_fliteral);
                  compile_real(*((Real *) &xt->func[0]));
                  break;
            case A_COLON:
                  compile_cell((Cell) _paren_do_colon_paren);
                  compile_cell((Cell) &xt->func[0]);
                  break;
            case A_CREATE:
                  compile_cell((Cell) _do_literal);
                  compile_cell((Cell) &xt->func[1]);
                  if (xt->func[0]) {
                        compile_cell((Cell) _paren_do_colon_paren);
                        compile_cell((Cell) xt->func[0]);
                  }
                  break;
            case A_LOCAL:
                  compile_cell((Cell) _paren_read_local_paren);
                  compile_cell((Cell) xt->func[0]);
                  break;
            case A_MARKER:
                  compile_cell((Cell) _paren_marker_paren);
                  compile_cell((Cell) &xt->func[0]);
                  break;
            default: _error = E_NOVOC; break;
      }
}

/* save_input_specification: save all the information needed to restore the
 * state of current input later. First the word "save-input" is called, and
 * then each Cell on the stack is copied in the return stack
 */
void save_input_specification() {
      register int dim, dim1;
      _save_input();
      dim1 = dim = *sp++;
      while (dim--) _to_r();
      *--sp = (Cell) dim1;
      _to_r();
}

/* restore_input_specification: restore the input source by calling
 * "restore-input" after that the Cells on the return stack has been moved
 * on the data stack
 */
void restore_input_specification() {
      register int dim = *rp++, dim1 = dim;
      while (dim--) _r_from();
      *--sp = (Cell) dim1;
      _restore_input();
      sp++;
}

/* check_system: perform some tests to verify that's everything ok */
void check_system() {
      if (sp > sp_top) _error = E_DSTK_UNDER;
      else if (sp < sp_base) _error = E_DSTK_OVER;
      else if (rp > rp_top) _error = E_RSTK_UNDER;
      else if (rp < rp_base) _error = E_RSTK_OVER;
      else if (fstack_size && fp > fp_top) _error = E_FSTK_UNDER;
      else if (fstack_size && fp < fp_base) _error = E_FSTK_OVER;
      else if (_dp < dp0) _error = E_DSPACE_UNDER;
      else if (_dp > dp0 + dspace_size) _error = E_DSPACE_OVER;
}