foci/main.c

#include <stdint.h>
#include <stdio.h>

#define NAKED __attribute__((naked))

#define END_OF(arr) ((arr) + (sizeof((arr)) / sizeof(*(arr))))
#define NEXT        { goto *(*++pp); }

#define LIT(x)  push, (void *)(x)
#define FTH(w)  enter, (w##_body)
#define EXIT    doexit

#define ATTR_NATIVE     (1 << 7)
#define ATTR_IMMEDIATE  (1 << 6)
#define ATTR_LEN        (0x3F)

#define WORD(name, tname, prev, attr) \
    extern const void *name##_body[]; \
    struct word_t w_##name = { \
        name##_body, prev, attr + sizeof(tname) - 1, tname \
    }; \
    const void *name##_body[] = {
#define END    EXIT, };

#define W(name, tname, prev) WORD(name, tname, prev, 0)
#define N(name, tname, prev) WORD(name, tname, prev, ATTR_NATIVE)
#define I(name, tname, prev) WORD(name, tname, prev, ATTR_IMMEDIATE)

struct word_t
{
    const void **body;
    struct word_t *prev;
    unsigned char attr;
    char name[];
} __attribute__ ((packed));

intptr_t dstack[32];
intptr_t **rstack[32];
intptr_t dict[8192];

register intptr_t     tmp asm("r12");
register intptr_t *   sp  asm("r13"); // pointer to stack cells
register intptr_t *** rp  asm("r14"); // stack of pp
register intptr_t **  pp  asm("r15"); // pointer to ip

#define STASH   asm("push %r12; push %r13; push %r14; push %r15")
#define RESTORE asm("pop %r15; pop %r14; pop %r13; pop %r12")

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

NAKED
void sp_at()
{
    *sp = (intptr_t)sp;
    sp = sp - 1;
    NEXT;
}

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

void doexit()
{
    if (rp < END_OF(rstack)) {
        pp = *rp++;
        NEXT;
    }

    pp = 0;
}

intptr_t state = 0;
intptr_t *here = dict;

NAKED void  drop() { ++sp;                 NEXT; }
NAKED void  swap() { tmp = sp[0]; sp[0] = sp[1]; sp[1] = tmp; NEXT; }
NAKED void   add() { sp[1] += sp[0]; ++sp; NEXT; }
NAKED void   sub() { sp[1] -= sp[0]; ++sp; NEXT; }
NAKED void   mul() { sp[1] *= sp[0]; ++sp; NEXT; }
NAKED void   div() { sp[1] /= sp[0]; ++sp; NEXT; }
NAKED void   mod() { sp[1] %= sp[0]; ++sp; NEXT; }
NAKED void   and() { sp[1] &= sp[0]; ++sp; NEXT; }
NAKED void    or() { sp[1] |= sp[0]; ++sp; NEXT; }
NAKED void   xor() { sp[1] ^= sp[0]; ++sp; NEXT; }
NAKED void  cell() { *--sp = sizeof(*sp);  NEXT; }
NAKED void  peek() { *sp = *(intptr_t *)*sp; NEXT; }
NAKED void  poke() { *(intptr_t *)sp[0] = sp[1]; sp -= 2; NEXT; }
NAKED void cpeek() { *sp = *(char *)*sp; NEXT; }
NAKED void cpoke() { *(char *)sp[0] = sp[1]; sp -= 2; NEXT; }
NAKED void  comp() { state = -1; NEXT; }
NAKED void  intr() { state = 0; NEXT; }
NAKED void   dot() { printf("%ld ", *sp++); NEXT; }
NAKED void comma() { *here++ = *sp++; NEXT; }

NAKED void align() {
    here = (intptr_t *)(((intptr_t)here + sizeof(intptr_t) - 1)
        & ~(sizeof(intptr_t) - 1));
    NEXT;
}

NAKED void colon()
{
    extern struct word_t *latest;
    static int ch;

    tmp = (intptr_t)here++; // body
    *here++ = (intptr_t)latest;

    STASH;
    for (;;) {
        ch = getchar();

        if (ch <= 0x20)
            break;

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

    here = (intptr_t *)(((intptr_t)here + sizeof(intptr_t) - 1)
        & ~(sizeof(intptr_t) - 1));
    *(intptr_t *)tmp = (intptr_t)here;
    NEXT;
}

//W(two,  "2",            &w_dup)  LIT(2), FTH(dup), END

W(dup,   "dup",         0)        sp_at, peek,      END
W(drop,  "drop",        &w_dup)   drop,             END
W(swap,  "swap",        &w_drop)  swap,             END
W(peek,  "@",           &w_swap)  peek,             END
W(poke,  "!",           &w_peek)  poke,             END
W(cpeek, "c@",          &w_poke)  cpeek,            END
W(cpoke, "c!",          &w_cpeek) cpoke,            END
W(add,   "+",           &w_cpoke) add,              END
W(sub,   "-",           &w_add)   sub,              END
W(mul,   "*",           &w_sub)   mul,              END
W(div,   "/",           &w_mul)   div,              END
W(mod,   "mod",         &w_div)   mod,              END
W(and,   "and",         &w_mod)   and,              END
W(or,    "or",          &w_and)   or,               END
W(xor,   "xor",         &w_or)    xor,              END
W(cell,  "cell",        &w_xor)   cell,             END
W(cellp, "cell+",       &w_cell)  cell, add,        END
W(cells, "cells",       &w_cellp) cell, mul,        END
W(dict,  "_d",          &w_cells) LIT(dict),        END
W(here,  "here",        &w_dict)  LIT(&here), peek, END
I(intr,  "[",           &w_here)  intr,             END
W(comp,  "]",           &w_intr)  comp,             END
W(dot,   ".",           &w_comp)  dot,              END
W(colon, ":",           &w_dot)   colon,            END
W(align, "align",       &w_colon) align,            END
W(comma, ",",           &w_align) comma,            END
struct word_t *latest = &w_comma;

void init()
{
    sp = END_OF(dstack);
    rp = END_OF(rstack);
    pp = 0;
}

void dump()
{
    //printf("IP: %ld\n", (intptr_t)pp);

    printf("DS: ");
    intptr_t *it = END_OF(dstack) - 1;
    while (it >= sp) {
        printf("%ld ", *it);
        --it;
    }
    putchar('\n');

    //printf("RS: ");
    //intptr_t ***rt = END_OF(rstack) - 1;
    //while (rt >= rp) {
    //    printf("%ld ", (intptr_t)*rt);
    //    --rt;
    //}
    //putchar('\n');
}

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

//struct word_t
//{
//    const void **body;
//    struct word_t *prev;
//    unsigned char attr;
//    char name[];
//} __attribute__ ((packed));

//NAKED void key() { *--sp = getchar(); NEXT; }

#include <ctype.h>
#include <string.h>

extern long strtol(char *, char **, int);

int base = 10;

int main()
{
    char buf[128];

    init();

    for (;;) {
        //dump();
        printf("> ");

        char c;
        do c = getchar();
        while (!isgraph(c));

        char *s = buf;
        do {
            *s++ = c;
            c = getchar();
        } while (isgraph(c));
        *s = '\0';

        if (strcmp(buf, "bye") == 0)
            break;

        struct word_t *l;
        for (l = latest; l; l = l->prev) {
            if (strncmp(buf, l->name, l->attr & ATTR_LEN) == 0)
                break;
        }

        if (l == 0) {
            char *end;
            long n = strtol(buf, &end, base);
            if (*end == '\0') {
                if (state) {
                    *here++ = (intptr_t)push;
                    *here++ = n;
                } else {
                    *--sp = n;
                }
            } else {
                puts("word not found");
            }
        } else {
            if (state && !(l->attr & ATTR_IMMEDIATE)) {
                *here++ = (intptr_t)l->body;
            } else {
                call(l->body);
            }
        }

        puts(state ? "compiled" : "ok");
    }

    return 0;
}