alx/ueforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

run more

Browse Source
This commit is contained in:
Brad Nelson
2020-12-28 14:20:40 -08:00
parent bc3d5cbf3c
commit 9a08223cdc
1 changed files with 70 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

99
forth.c
View File

@ -17,7 +17,8 @@ typedef int64_t dcell_t;
#define DUP *++sp = tos
#define DROP tos = *sp--
#define NEXT w = *ip++; goto *(void **) w
#define NEXT w = *ip++; goto **(void **) w
#define CELL_LEN(n) (((n) + sizeof(cell_t) - 1) & ~(sizeof(cell_t) - 1))
#define OPCODE_LIST \
X("0=", OP_ZEQUAL, tos = !tos) \
@ -51,11 +52,11 @@ typedef int64_t dcell_t;
X("BRANCH", OP_BRANCH, ip = (cell_t *) *ip) \
X("0BRANCH", OP_ZBRANCH, if (!tos) ip = (cell_t *) *ip; else ++ip; DROP) \
X("DOLIT", OP_DOLIT, DUP; tos = *(cell_t *) ip++) \
X("FIND", OP_FIND, tos = find((cell_t *) *sp, tos, sp)) \
X("FIND", OP_FIND, tos = find(*(cell_t *) *sp, tos, sp)) \
X("PARSE", OP_PARSE, DUP; tos = parse(tos, sp)) \
X("CREATE", OP_CREATE, t = parse(32, &w); \
create((const char *) w, t, 0, && OP_DOCREATE)) \
X("IMMEDIATE", OP_IMMEDIATE, ) \
X("CREATE", OP_CREATE, t = parse(32, &tmp); \
create((const char *) tmp, t, 0, && OP_DOCREATE)) \
X("IMMEDIATE", OP_IMMEDIATE, g_last[-1] |= 1) \
X("DOES>", OP_DOES, *g_heap++ = (cell_t) && OP_DODOES /* TODO */) \
X("HERE", OP_HERE, DUP; tos = (cell_t) g_heap) \
X("ALLOT", OP_ALLOT, g_heap = (cell_t *) (tos + (cell_t) g_heap); tos = *sp--) \
@ -65,15 +66,16 @@ typedef int64_t dcell_t;
X("&TIB", OP_TIB, DUP; tos = (cell_t) &g_tib) \
X("#TIB", OP_NTIB, DUP; tos = (cell_t) &g_ntib) \
X(">IN", OP_TIN, DUP; tos = (cell_t) &g_tin) \
X(":", OP_COLON, t = parse(32, &w); \
create((const char *) w, t, 0, && OP_DOCOL); \
X(":", OP_COLON, t = parse(32, &tmp); \
create((const char *) tmp, t, 0, && OP_DOCOL); \
g_state = -1) \
X("EXIT", OP_EXIT, ip = (void *) *rp--) \
X("QUIT", OP_QUIT, DUP; sp = quit(sp, &tmp); \
DROP; --ip; if (tmp) (w = tmp); \
if (tmp) goto **(void **) w) \
X(";", OP_SEMICOLON, *g_heap++ = (cell_t) g_last; g_state = 0) \
X("QUIT", OP_QUIT, quit(); --ip) \
static const char boot[] =
" -123 "
// Comments
" : ( 41 parse drop drop ; immediate "
@ -169,6 +171,7 @@ static cell_t g_ntib = sizeof(boot), g_tin = 0;
static cell_t *g_last = 0;
static cell_t g_base = 10;
static cell_t g_state = 0;
static cell_t g_DOLIT_XT;
static cell_t convert(const char *pos, cell_t n, cell_t *ret) {
*ret = 0;
@ -190,19 +193,33 @@ static cell_t convert(const char *pos, cell_t n, cell_t *ret) {
return -1;
}
static cell_t find(cell_t *name, cell_t len, cell_t *ret) {
static cell_t same(const char *a, const char *b, cell_t len) {
for (;len && (*a & 95) == (*b & 95); --len, ++a, ++b);
return len;
}
static cell_t find(cell_t name, cell_t len, cell_t *ret) {
cell_t *pos = g_last;
cell_t clen = CELL_LEN(len);
while (pos) {
if (len == pos[-3] &&
same((const char *) name, (const char *) &pos[-3 - clen], len) == 0) {
*ret = (cell_t) pos;
return -1;
}
pos = (cell_t *) pos[-2]; // Follow link
}
return 0;
}
static void create(const char *name, cell_t length, cell_t flags, void *op) {
cell_t *start = g_heap;
*g_heap++ = length; // length
memcpy(g_heap, name, length); // name
g_heap += ((sizeof(name) + sizeof(cell_t) - 1) & ~(sizeof(cell_t)-1));
g_heap += CELL_LEN(length);
*g_heap++ = length; // length
*g_heap++ = (cell_t) g_last; // link
*g_heap++ = flags; // flags
g_last = g_heap;
*g_heap++ = (cell_t) op; // code
g_last = start;
}
static cell_t parse(cell_t sep, cell_t *ret) {
@ -212,32 +229,56 @@ static cell_t parse(cell_t sep, cell_t *ret) {
return g_tin - (*ret - (cell_t) g_tib);
}
static void quit(void) {
static cell_t *quit(cell_t *sp, cell_t *call) {
*call = 0;
cell_t name;
cell_t len = parse(' ', &name);
cell_t n;
cell_t ok = convert((const char *) name, len, &n);
if (ok) {
printf("NUM: %d\n", (int)n);
cell_t xt;
cell_t found = find(name, len, &xt);
if (found) {
if (g_state && !(((cell_t *) xt)[-1] & 1)) { // bit 0 of flags is immediate
*g_heap++ = xt;
} else {
*call = xt;
}
} else {
printf("WORD(%d): ", (int)len);
fwrite((const char *) name, 1, len, stdout);
printf("\n");
cell_t n;
cell_t ok = convert((const char *) name, len, &n);
if (ok) {
if (g_state) {
*g_heap++ = g_DOLIT_XT;
*g_heap++ = n;
} else {
*sp += n;
}
} else {
fprintf(stderr, "Bad Word: ");
fwrite((const char *) name, 1, len, stderr);
fprintf(stderr, "\n");
exit(1);
}
}
return sp;
}
int main(int argc, char *argv[]) {
g_heap = malloc(HEAP_SIZE);
cell_t *sp = (g_heap += STACK_SIZE), *rp = (g_heap += STACK_SIZE);
cell_t tos = 0, t, w;
register cell_t *sp = g_heap; g_heap += STACK_SIZE;
register cell_t *rp = g_heap; g_heap += STACK_SIZE;
register cell_t tos = 0, *ip, t, w;
dcell_t m, n, d;
cell_t *ip = g_heap;
*g_heap++ = (cell_t) && OP_QUIT;
g_tib = boot;
#define X(name, op, code) create(name, sizeof(name), name[0] == ';', && op);
cell_t tmp;
#define X(name, op, code) create(name, sizeof(name) - 1, name[0] == ';', && op);
OPCODE_LIST
#undef X
#define X(name, op, code) op: code; NEXT;
g_last[-1] = 1; // Make ; IMMEDIATE
find((cell_t) "DOLIT", 5, &g_DOLIT_XT);
ip = g_heap;
find((cell_t) "QUIT", 4, g_heap++);
g_tib = boot;
fprintf(stderr, "right: %p\n", && OP_COLON);
NEXT;
#define X(name, op, code) op: fprintf(stderr, name "\n"); code; NEXT;
OPCODE_LIST
#undef X
OP_DOCREATE: DUP; tos = w + sizeof(cell_t) * 2; NEXT;