foci/foci.c

// foci - minimal forth implementation
// Copyright (C) 2025  Clyne Sullivan <clyne@bitgloo.com>
//
// This program is free software: you can redistribute it and/or modify it
// under the terms of the GNU General Public License as published by the Free
// Software Foundation, either version 3 of the License, or (at your option)
// any later version.
//
// This program is distributed in the hope that it will be useful, but WITHOUT
// ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
// FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
// more details.
//
// You should have received a copy of the GNU General Public License along with
// this program.  If not, see <http://www.gnu.org/licenses/>.

#include "foci.h"

#define END_OF(arr) ((arr) + (sizeof((arr)) / sizeof(*(arr))))

static intptr_t dstack[32];
static intptr_t **rstack[32];
static intptr_t dict[8192] = {
    0, 10
};
#define state dict[0]
#define BASE  dict[1]
#define begin dict[2]
static intptr_t *here = &begin;
static struct word_t *latest;

static intptr_t     saved_tmp;
static intptr_t *   saved_sp;
static intptr_t *** saved_rp;
static intptr_t **  saved_pp;

NAKED void enter(void) { *--rp = ++pp; pp = (intptr_t **)*pp; goto *(*pp); }
NAKED void  push(void) { *--sp = (intptr_t)*++pp; NEXT; }
      void fexit(void) { if (rp < END_OF(rstack)) { pp = *rp++; NEXT; } }

NAKED void compname(void)
{
    static int ch;

    STASH;
    *(unsigned char *)here = 0;
    for (;;) {
        ch = foci_getchar();

        if (ch <= 0x20)
            break;

        *(unsigned char *)here += 1;
        ((char *)here)[*(unsigned char *)here] = ch;
    }
    RESTORE;
    *--sp = *(unsigned char *)here;

    NEXT;
}

int compare(const char *a, const char *b, int l)
{
    for (; l--; a++, b++) {
        if (*a != *b)
            return 1;
    }

    return 0;
}

struct word_t *lookup_p(const char *s, int len)
{
    for (struct word_t *l = latest; l; l = l->prev) {
        if (len == (l->attr & ATTR_LEN) && !compare(s, l->name, len))
            return l;
    }

    return 0;
}

NAKED
void lookup()
{
    static struct word_t *l;

    STASH;
    l = lookup_p((char *)((intptr_t)here + 1), *(char *)here);
    RESTORE;

    *--sp = (intptr_t)l;
    NEXT;
}

N(dup,    "dup",    0)        { --sp; sp[0] = sp[1]; NEXT; }
N(drop,   "drop",   &w_dup)   { ++sp; NEXT; }
N(swap,   "swap",   &w_drop)  { tmp = sp[0]; sp[0] = sp[1]; sp[1] = tmp; NEXT; }
N(rot,    "rot",    &w_swap)  { tmp = sp[0]; sp[0] = sp[2]; sp[2] = sp[1];
                                sp[1] = tmp; NEXT; }
N(peek,   "@",      &w_rot)   { *sp = *(intptr_t *)*sp; NEXT; }
N(poke,   "!",      &w_peek)  { *(intptr_t *)sp[0] = sp[1]; sp += 2; NEXT; }
N(cpeek,  "c@",     &w_poke)  { *sp = *(char *)*sp; NEXT; }
N(cpoke,  "c!",     &w_cpeek) { *(char *)sp[0] = (char)sp[1]; sp += 2; NEXT; }
N(add,    "+",      &w_cpoke) { sp[1] += sp[0]; ++sp; NEXT; }
W(addto,  "+!",     &w_add)   dup, peek, rot, add, swap, poke, END
N(sub,    "-",      &w_addto) { sp[1] -= sp[0]; ++sp; NEXT; }
N(mul,    "*",      &w_sub)   { sp[1] *= sp[0]; ++sp; NEXT; }
N(ndiv,   "/",      &w_mul)   { sp[1] /= sp[0]; ++sp; NEXT; }
N(mod,    "mod",    &w_ndiv)  { sp[1] %= sp[0]; ++sp; NEXT; }
N(and,    "and",    &w_mod)   { sp[1] &= sp[0]; ++sp; NEXT; }
N(or,     "or",     &w_and)   { sp[1] |= sp[0]; ++sp; NEXT; }
N(xor,    "xor",    &w_or)    { sp[1] ^= sp[0]; ++sp; NEXT; }
N(compname, "_c",   &w_xor)   ;
C(intr,   "[",      &w_compname) { state = 0; NEXT; }
N(comp,   "]",      &w_intr)  { state = -1; NEXT; }
N(comma,  ",",      &w_comp)  { *here++ = *sp++; NEXT; }
W(cell,   "cell",   &w_comma)   LIT(sizeof(*sp)),   END
W(cellp,  "cell+",  &w_cell)    FTH(cell), add,     END
W(cells,  "cells",  &w_cellp)   FTH(cell), mul,     END
W(dict,   "_d",     &w_cells)   LIT(dict),          END
W(base,   "base",   &w_dict)    LIT(&BASE), END
W(here,   "here",   &w_base)    LIT(&here), peek,   END
W(allot,  "allot",  &w_here)    LIT(&here), FTH(addto), END
W(latest, "latest", &w_allot)   LIT(&latest), peek, END
W(negate, "negate", &w_latest)  LIT(-1), mul, END
W(invert, "invert", &w_negate)  LIT(-1), xor, END
W(dec,    "1-",     &w_invert)  LIT(1), sub,  END
W(inc,    "1+",     &w_dec)     LIT(1), add,  END
W(aligned, "aligned", &w_inc)   LIT(sizeof(*sp) - 1), add, LIT(~(sizeof(*sp) - 1)),
                                and, END
W(align,  "align",  &w_aligned) FTH(here), FTH(aligned), LIT(&here), poke, END
W(colon,  ":",      &w_align)   FTH(here), LIT(0), comma, FTH(latest), comma,
                                compname, FTH(allot), FTH(align), dup,
                                FTH(here), swap, poke, comp, END
I(semic,  ";",      &w_colon)   LIT(fexit), comma, LIT(&latest), poke, intr, END
I(literal, "literal", &w_semic) LIT(push), comma, comma, END
N(b,      "_b",     &w_literal) { ++pp; pp = (intptr_t **)*pp; NEXT; }
N(bz,     "_bz",    &w_literal) { ++pp; if (!*sp++) { pp = (intptr_t **)*pp; } NEXT; }
I(fif,    "if",     &w_b)       LIT(bz), comma, FTH(here), LIT(0), comma, END
I(then,   "then",   &w_fif)     FTH(here), LIT(sizeof(intptr_t)), sub, swap, poke, END
I(felse,  "else",   &w_then)    LIT(b), comma, FTH(here), LIT(0), comma, swap, FTH(then), END
W(tick,   "\'",     &w_felse)   compname, drop, lookup, peek, END
N(execute, "execute", &w_tick)  { pp = (intptr_t **)*sp++ - 1; NEXT; }
W(decimal, "decimal", &w_execute) LIT(10), LIT(&BASE), poke, END
W(hex,    "hex",    &w_decimal) LIT(16), LIT(&BASE), poke, END
#define LATEST      &w_hex

void call(void *ptr)
{
    pp = ptr;
    ((void (*)())*pp)();
}

intptr_t parse_number(const char *s, const char **endp, int b)
{
    intptr_t n = 0;
    int neg;

    if (*s == '-') {
        neg = 1;
        s++;
    } else {
        neg = 0;
    }

    while (*s >= '0' && *s <= " 0123456789abcdef"[b]) {
        n *= b;
        n += *s;
        n -= *s <= '9' ? '0' : ('a' - 10);
        s++;
    }

    *endp = s;
    return neg ? n * -1 : n;
}

void parse_word(const char *buf, const char *s)
{
    struct word_t *l = lookup_p(buf, s - buf);

    tmp = saved_tmp;
    sp = saved_sp;
    rp = saved_rp;
    pp = saved_pp;

    if (l == 0) {
        const char *end;
        intptr_t n = parse_number(buf, &end, BASE);
        if (*end == '\0') {
            if (state) {
                *here++ = (intptr_t)push;
                *here++ = n;
            } else {
                *--sp = n;
            }
        } else {
            const char *err = "word not found";
            while (*err)
                foci_putchar(*err++);
        }
    } else {
        if (state && !(l->attr & ATTR_IMMEDIATE)) {
            if (!(l->attr & ATTR_NATIVE)) {
                *here++ = (intptr_t)enter;
                *here++ = (intptr_t)l->body;
            } else {
                *here++ = (intptr_t)l->body[0];
            }
        } else {
            call(l->body);
        }
    }

    saved_tmp = tmp;
    saved_sp = sp;
    saved_rp = rp;
    saved_pp = pp;
}

void init(void)
{
    saved_tmp = 0;
    saved_sp = END_OF(dstack);
    saved_rp = END_OF(rstack);
    saved_pp = 0;

    latest = LATEST;
}

int depth(void)
{
    return END_OF(dstack) - saved_sp;
}

int compiling(void)
{
    return state;
}

void define(struct word_t *w)
{
    w->prev = latest;
    latest = w;
}