From 6dc05560eb055316fd80fd592aa5424ac5a90b27 Mon Sep 17 00:00:00 2001 From: Brad Nelson Date: Sun, 27 Dec 2020 23:13:56 -0800 Subject: [PATCH] adding things --- .gitignore | 1 + Makefile | 6 ++ forth.c | 206 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 213 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 forth.c diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..774ae26 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +forth diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e3609eb --- /dev/null +++ b/Makefile @@ -0,0 +1,6 @@ +forth: forth.c + +CFLAGS=-Wall -Werror + +clean: + rm -f forth diff --git a/forth.c b/forth.c new file mode 100644 index 0000000..2f59298 --- /dev/null +++ b/forth.c @@ -0,0 +1,206 @@ +#include +#include +#include +#include + +#define HEAP_SIZE (1024 * 1024) +#define STACK_SIZE (1024 * 1024) + +typedef intptr_t cell_t; +#if __SIZEOF_POINTER__ == 8 +typedef __int128_t dcell_t; +# define CELL_BITS 3 +#elif __SIZEOF_POINTER__ == 4 +typedef int64_t dcell_t; +# define CELL_BITS 2 +#else +# error "unsupported cell size" +#endif + +#define DUP *++sp = tos +#define DROP tos = *sp-- +#define NEXT w = *ip++; goto *(void **) w + +#define OPCODE_LIST \ + X("0=", OP_ZEQUAL, tos = !tos) \ + X("0<", OP_ZLESS, tos = tos < 0) \ + X("+", OP_PLUS, tos += *sp--) \ + X("*/MOD", OP_SSMOD, d = (dcell_t) tos; \ + m = (dcell_t) *sp; \ + n = (dcell_t) sp[-1]; \ + n *= m; \ + tos = (cell_t) (n / d); \ + *--sp = (cell_t) (n % d)) \ + X("AND", OP_AND, tos &= *sp--) \ + X("OR", OP_OR, tos |= *sp--) \ + X("XOR", OP_XOR, tos ^= *sp--) \ + X("DUP", OP_DUP, DUP) \ + X("SWAP", OP_SWAP, t = tos; tos = *sp; *sp = t) \ + X("OVER", OP_OVER, DUP; tos = sp[-1]) \ + X("DROP", OP_DROP, DROP) \ + X("SP@", OP_SPAT, DUP; tos = (cell_t) sp) \ + X("SP!", OP_SPSTORE, sp = (cell_t *) tos; DROP) \ + X("RP@", OP_RPAT, DUP; tos = (cell_t) rp) \ + X("RP!", OP_RPSTORE, rp = (cell_t *) tos; DROP) \ + X(">R", OP_TOR, *++rp = tos; DROP) \ + X("R>", OP_FROMR, DUP; tos = *rp--) \ + X("R@", OP_RAT, DUP; tos = *rp) \ + X("CELL", OP_CELL, DUP; tos = sizeof(cell_t)) \ + X("@", OP_AT, tos = *(cell_t *) tos) \ + X("C@", OP_CAT, tos = *(uint8_t *) tos) \ + X("!", OP_STORE, *(cell_t *) tos = *sp; --sp; DROP) \ + X("C!", OP_CSTORE, *(uint8_t *) tos = *sp; --sp; DROP) \ + 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(last, (cell_t *) *sp, tos, sp)) \ + X("PARSE", OP_PARSE, DUP; tos = parse(tib, ntib, &tin, tos, sp)) \ + X("CREATE", OP_CREATE, t = parse(tib, ntib, &tin, 32, &w); \ + create(&heap, &last, (const char *) w, t, 0, && OP_DOCREATE)) \ + X("IMMEDIATE", OP_IMMEDIATE, ) \ + X("DOES>", OP_DOES, *heap++ = (cell_t) && OP_DODOES /* TODO */) \ + X("HERE", OP_HERE, DUP; tos = (cell_t) heap) \ + X("ALLOT", OP_ALLOT, heap = (cell_t *) (tos + (cell_t) heap); tos = *sp--) \ + X("STATE", OP_STATE, DUP; tos = (cell_t) &state) \ + X("BASE", OP_BASE, DUP; tos = (cell_t) &base) \ + X("LAST", OP_LAST, DUP; tos = (cell_t) &last) \ + X("&TIB", OP_TIB, DUP; tos = (cell_t) &tib) \ + X("#TIB", OP_NTIB, DUP; tos = (cell_t) &ntib) \ + X(">IN", OP_TIN, DUP; tos = (cell_t) &tin) \ + X(":", OP_COLON, t = parse(tib, ntib, &tin, 32, &w); \ + create(&heap, &last, (const char *) w, t, 0, && OP_DOCOL); \ + state = -1) \ + X("EXIT", OP_EXIT, ip = (void *) *rp--) \ + X(";", OP_SEMICOLON, *heap++ = (cell_t) last; state = 0) \ + +static const char *boot = +// Comments +" : ( 41 parse drop drop ; immediate " + +// Useful Basic Compound Words +" : 2drop ( n n -- ) drop drop ; " +" : 2dup ( a b -- a b a b ) over over ; " +" : nip ( a b -- b ) swap drop ; " +" : rdrop ( r: n n -- ) r> r> drop >r ; " +" : */ ( n n n -- n ) */mod nip ; " +" : * ( n n -- n ) 1 */ ; " +" : /mod ( n n -- n n ) 1 swap */mod ; " +" : / ( n n -- n ) /mod nip ; " +" : mod ( n n -- n ) /mod drop ; " +" : invert ( n -- ~n ) -1 xor ; " +" : negate ( n -- -n ) invert 1 + ; " +" : - ( n n -- n ) negate + ; " +" : rot ( a b c -- c a b ) >r swap r> swap ; " +" : -rot ( a b c -- b c a ) swap >r swap r> ; " +" : cell+ ( n -- n ) cell + ; " +" : cells ( n -- n ) cell * ; " +" : < ( a b -- a ( a b -- a>b ) swap - 0< ; " +" : = ( a b -- a!=b ) - 0= ; " +" : <> ( a b -- a!=b ) = 0= ; " +" : emit ( n -- ) >r rp@ 1 type rdrop ; " +" : bl 32 ; : space bl emit ; " +" : nl 10 ; : cr nl emit ; " + +// Compilation State +" : [ 0 state ! ; immediate " +" : ] -1 state ! ; immediate " + +// Quoting Words +" : ' parse-name find ; " +" : ['] ' aliteral ; immediate " +" : char parse-name drop c@ ; " +" : [char] char aliteral ; immediate " +" : literal aliteral ; immediate " + +// Core Control Flow +" : begin here ; immediate " +" : again ['] branch , , ; immediate " +" : until ['] 0branch , , ; immediate " +" : ahead ['] branch , here 0 , ; immediate " +" : then here swap ! ; immediate " +" : if ['] 0branch , here 0 , ; immediate " +" : else ['] branch , here 0 , swap here swap ! ; immediate " + +// Compound words requiring conditionals +" : min 2dup < if drop else nip then ; " +" : max 2dup < if nip else drop then ; " + +// Postpone - done here so we have ['] and IF +" : >flags 2 cells - @ ; " +" : immediate? >flags 1 and 1 - 0= ; " +" : postpone ' dup immediate? if , else aliteral ['] , , then ; immediate " + +// Counted Loops +" : do postpone swap postpone >r postpone >r here ; immediate " +" : i postpone r@ ; immediate " +" : unloop postpone rdrop postpone rdrop ; immediate " +" : +loop postpone r> postpone + postpone r> " +" postpone 2dup postpone >r postpone >r " +" postpone < postpone 0= postpone until " +" postpone unloop ; immediate " +" : loop 1 aliteral postpone +loop ; immediate " + +// Constants and Variables +" : constant create , does> @ ; " +" : variable create 0 , ; " + +// Exceptions +" variable handler " +" : catch sp@ >r handler @ >r rp@ handler ! execute r> handler ! r> drop 0 ; " +" : throw handler @ rp! r> handler ! r> swap >r sp! drop r> ; " + +// Examine Dictionary +" : >link ( xt -- a ) 1 cells - @ ; : >flags 2 cells - ; " +" : >name ( xt -- a n ) dup 3 cells - @ swap over - 3 cells - swap ; " +" : >body ( xt -- a ) cell+ ; " +" : see. ( xt -- ) >name type space ; " +" : see-one ( xt -- xt+1 ) " +" dup @ dup ['] dolit: = if drop cell+ dup @ . else see. then cell+ ; " +" : exit= ( xt -- ) ['] exit = ; " +" : see-loop >body begin see-one dup @ exit= until ; " +" : see cr ['] : see. ' dup see. see-loop drop ['] ; see. cr ; " +" : words last @ begin dup >name type space >link dup 0= until drop cr ; " +; + +static cell_t find(cell_t *last, cell_t *name, cell_t len, cell_t *ret) { + return 0; +} + +static void create(cell_t **heap, cell_t **last, + const char *name, cell_t length, cell_t flags, void *op) { + cell_t *start = *heap; + *(*heap)++ = length; // length + memcpy((*heap), name, length); // name + (*heap) += ((sizeof(name) + sizeof(cell_t) - 1) >> CELL_BITS); + *(*heap)++ = (cell_t) *last; // link + *(*heap)++ = flags; // flags + *(*heap)++ = (cell_t) op; // code + *last = start; +} + +static cell_t parse(const char *tib, cell_t ntib, cell_t *tin, cell_t sep, cell_t *ret) { + return 0; +} + +int main(int argc, char *argv[]) { + cell_t *heap = malloc(HEAP_SIZE); + cell_t *stack = malloc(STACK_SIZE); + cell_t *rstack = malloc(STACK_SIZE); + cell_t state = 0, base = 10, *last = 0, tos = 0, t, w; + cell_t *sp = stack, *rp = rstack; + dcell_t m, n, d; + const char *tib = boot; + cell_t ntib = sizeof(boot), tin = 0; + cell_t *ip = heap; +#define X(name, op, code) create(&heap, &last, name, sizeof(name), name[0] == ';', && op); + OPCODE_LIST +#undef X +#define X(name, op, code) op: code; NEXT; + OPCODE_LIST +#undef X + OP_DOCREATE: DUP; tos = w + sizeof(cell_t) * 2; NEXT; + OP_DODOES: DUP; tos = w + sizeof(cell_t) * 2; + *++rp = (cell_t) ip; ip = (cell_t *) (w + sizeof(cell_t)); NEXT; + OP_DOCOL: *++rp = (cell_t) ip; ip = (cell_t *) (w + sizeof(cell_t)); NEXT; +}