path: root/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 STATE;
static intptr_t BASE;
static intptr_t LATEST;

static intptr_t dstack[FOCI_DATA_STACK_SIZE];
static intptr_t **rstack[FOCI_RETURN_STACK_SIZE];
static intptr_t *dictmem;
static intptr_t *here;
static char *in;
static intptr_t *saved_sp;
static intptr_t ***saved_rp;

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

void fend(void) {}
static const void * const fend_b[2] = { 0, fend };

NAKED void compname(void)
{
    STASH;
    *(unsigned char *)here = 0;

    for (; *in <= ' '; in++) {
        if (*in == '\0')
            break;
    }

    for (; *in > ' '; in++) {
        *(unsigned char *)here += 1;
        ((char *)here)[*(unsigned char *)here] = *in;
    }

    RESTORE;
    *--sp = *(unsigned char *)here + 1;
    NEXT;
}

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

    return 0;
}

const struct word_t *lookup_p(const char *s, int len)
{
    if (len < 1)
        return 0;

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

    return 0;
}

NAKED
void lookup()
{
    static const 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(mrot,   "-rot",   &w_rot)   { tmp = sp[2]; sp[2] = sp[0]; sp[0] = sp[1];
                                sp[1] = tmp; NEXT; }
N(over,   "over",   &w_mrot)  { --sp; sp[0] = sp[2]; NEXT; }
W(tuck,   "tuck",   &w_over)  swap, over, END
N(peek,   "@",      &w_tuck)  { *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(eq,     "=",      &w_xor)   { sp[1] = sp[0] == sp[1]; ++sp; NEXT; }
N(lt,     "<",      &w_eq)    { sp[1] = sp[0] > sp[1]; ++sp; NEXT; }
N(compname, "_c",   &w_lt)    ;
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
N(dict,   "_d",     &w_cells) { *--sp = (intptr_t)dictmem; NEXT; }
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_b)       { ++pp; if (!*sp++) { pp = (intptr_t **)*pp; } NEXT; }
I(fif,    "if",     &w_bz)      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
I(ctick,  "[\']",   &w_tick)    FTH(tick), FTH(literal), END
N(execute, "execute", &w_ctick) { 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
N(dot,    ".",      &w_hex)     ;
N(emit,   "emit",   &w_dot)     { foci_putchar(*sp++); NEXT; }
I(begin,  "begin",  &w_emit)    FTH(here), LIT(sizeof(intptr_t)), sub, END
I(until,  "until",  &w_begin)   LIT(bz), comma, comma, END
I(again,  "again",  &w_until)   LIT(b), comma, comma, END
I(fwhile, "while",  &w_again)   FTH(fif), END
I(repeat, "repeat", &w_fwhile)  swap, FTH(again), FTH(then), END
N(pushr,  ">r",     &w_repeat)  { *--rp = (intptr_t **)*sp++; NEXT; }
N(popr,   "r>",     &w_pushr)   { *--sp = (intptr_t)*rp++; NEXT; }
N(pushr2, "2>r",    &w_popr)    { *--rp = (intptr_t **)sp[1];
                                  *--rp = (intptr_t **)sp[0]; sp += 2; NEXT; }
N(popr2,  "2r>",    &w_pushr2)  { *--sp = (intptr_t)rp[1];
                                  *--sp = (intptr_t)rp[0]; rp += 2; NEXT; }
N(rpeek,  "r@",     &w_popr2)   { *--sp = (intptr_t)*rp; NEXT; }
N(i,      "i",      &w_rpeek)   { *--sp = (intptr_t)*rp; NEXT; }
I(fdo,    "do",     &w_i)       LIT(pushr2), comma, FTH(begin), END
I(loop,   "loop",   &w_fdo)     LIT(popr), comma,
                                LIT(enter), comma,
                                LIT(inc_body), comma,
                                LIT(rpeek), comma,
                                LIT(over), comma,
                                LIT(eq), comma,
                                LIT(swap), comma,
                                LIT(pushr), comma,
                                FTH(until),
                                LIT(popr2), comma,
                                LIT(drop), comma, LIT(drop), comma, END
W(immediate, "immediate", &w_loop) FTH(latest), LIT(2 * sizeof(intptr_t)), add,
                                   LIT(ATTR_IMMEDIATE), over, cpeek, or, swap, cpoke, END
#define LATEST_INIT &w_immediate

void enter_forth(const void *ptr)
{
    STASH;
    sp = saved_sp;
    rp = saved_rp;
    pp = ptr;

    *--rp = (intptr_t **)fend_b;
    ((void (*)())*pp)();

    saved_sp = sp;
    saved_rp = rp;
    RESTORE;
}

__attribute__((noinline))
static void dotimpl(intptr_t n)
{
    static const char dottbl[16] = "0123456789abcdef";
    static char dotbuf[16] = {0};
    int i = 0;

    if (n < 0) {
        n *= -1;
        foci_putchar('-');
    }

    do {
        dotbuf[i++] = dottbl[n % BASE];
        n /= BASE;
    } while (n);

    while (--i >= 0)
        foci_putchar(dotbuf[i]);

    foci_putchar(' ');
}

NAKED
void dot()
{
    STASH;
    dotimpl(*sp);
    RESTORE;
    ++sp;
    NEXT;
}

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;
}

static void parse_word(const char *start, const char *end)
{
    const struct word_t *l = lookup_p(start, end - start);

    if (l == 0) {
        const char *nend;
        intptr_t n = parse_number(start, &nend, BASE);
        if (nend == end) {
            if (STATE) {
                *here++ = (intptr_t)push;
                *here++ = n;
            } else {
                *--saved_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 {
            enter_forth(l->body);
        }
    }
}

void interpret(void)
{
    static char buf[80];
    char *s = buf - 1;

    do *++s = foci_getchar();
    while (*s && *s != '\n' && *s != '\r');
    *s = '\0';

    char *start = buf;
    for (in = buf; in <= s; in++) {
        if (*in <= ' ') {
            if (start != in)
                parse_word(start, in);

            start = in + 1;
        }
    }
}

void init(intptr_t *dictmemm)
{
    dictmem = dictmemm;
    STATE = 0;
    BASE = 10;
    LATEST = (intptr_t)LATEST_INIT;
    here = dictmem;
    in = 0;
    saved_sp = END_OF(dstack);
    saved_rp = END_OF(rstack);
}

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

int rdepth(void)
{
    return END_OF(rstack) - saved_rp;
}

int compiling(void)
{
    return STATE;
}

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