// foci - minimal forth implementation // Copyright (C) 2025 Clyne Sullivan // // 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 . #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] ? -1 : 0; ++sp; NEXT; } N(lt, "<", &w_eq) { sp[1] = sp[0] > sp[1] ? -1 : 0; ++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) { goto *&rpeek; } 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 // Be sure to update LATEST_INIT in foci.h! static void enter_forth(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((void *)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(const struct word_t *w) { //w->prev = (struct word_t *)LATEST; LATEST = (intptr_t)w; }