403 lines
13 KiB
C
403 lines
13 KiB
C
#include <inttypes.h>
|
|
#include <stdint.h>
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
|
|
#define HEAP_SIZE (10 * 1024 * 1024)
|
|
#define STACK_SIZE (16 * 1024)
|
|
|
|
typedef intptr_t cell_t;
|
|
#if __SIZEOF_POINTER__ == 8
|
|
typedef __int128_t dcell_t;
|
|
typedef __uint128_t udcell_t;
|
|
#elif __SIZEOF_POINTER__ == 4
|
|
typedef int64_t dcell_t;
|
|
typedef uint64_t udcell_t;
|
|
#else
|
|
# error "unsupported cell size"
|
|
#endif
|
|
|
|
#define DUP *++sp = tos
|
|
#define DROP tos = *sp--
|
|
#define NEXT w = *ip++; goto **(void **) w
|
|
#define CELL_LEN(n) (((n) + sizeof(cell_t) - 1) / sizeof(cell_t))
|
|
#define FIND(name) find(name, sizeof(name) - 1)
|
|
|
|
#define OPCODE_LIST \
|
|
X("0=", OP_ZEQUAL, tos = !tos ? -1 : 0) \
|
|
X("0<", OP_ZLESS, tos = tos < 0 ? -1 : 0) \
|
|
X("+", OP_PLUS, tos += *sp--) \
|
|
X("UM/MOD", OP_UMSMOD, ud = *(udcell_t *) &sp[-1]; \
|
|
*--sp = (cell_t) (ud % tos); \
|
|
tos = (cell_t) (ud / tos)) \
|
|
X("DONEXT", OP_DONEXT, if ((*rp)--) ip = (cell_t *) *ip; else (--rp, ++ip)) \
|
|
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_DOT, printf("%"PRIiPTR" ", tos); DROP) \
|
|
X("TYPE", OP_TYPE, fwrite((void *) *sp, 1, tos, stdout); DROP; DROP) \
|
|
X("KEY", OP_KEY, DUP; tos = fgetc(stdin)) \
|
|
X("SYSEXIT", OP_SYSEXIT, DUP; exit(tos)) \
|
|
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("ALITERAL", OP_ALITERAL, *g_heap++ = g_DOLIT_XT; *g_heap++ = tos; DROP) \
|
|
X("EXECUTE", OP_EXECUTE, w = tos; DROP; goto **(void **) w) \
|
|
X("FIND", OP_FIND, *sp = find((const char *) *sp, tos); DROP) \
|
|
X("PARSE", OP_PARSE, DUP; tos = parse(tos, sp)) \
|
|
X("CREATE", OP_CREATE, t = parse(32, &tmp); \
|
|
create((const char *) tmp, t, 0, && OP_DOCREATE); \
|
|
*g_heap++ = 0) \
|
|
X("IMMEDIATE", OP_IMMEDIATE, g_last[-1] |= 1) \
|
|
X("DOES>", OP_DOES, *g_last = (cell_t) && OP_DODOES; \
|
|
g_last[1] = (cell_t) ip; goto OP_EXIT) \
|
|
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--) \
|
|
X("STATE", OP_STATE, DUP; tos = (cell_t) &g_state) \
|
|
X("BASE", OP_BASE, DUP; tos = (cell_t) &g_base) \
|
|
X("LAST", OP_LAST, DUP; tos = (cell_t) &g_last) \
|
|
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("'THROW", OP_TTHROW, DUP; tos = (cell_t) &g_throw) \
|
|
X(":", OP_COLON, t = parse(32, &tmp); \
|
|
create((const char *) tmp, t, 0, && OP_DOCOL); \
|
|
g_state = -1) \
|
|
X("EVAL1", OP_EVAL1, DUP; sp = eval1(sp, &tmp); \
|
|
DROP; if (tmp) (w = tmp); \
|
|
if (tmp) goto **(void **) w) \
|
|
X("EXIT", OP_EXIT, ip = (void *) *rp--) \
|
|
X(";", OP_SEMICOLON, *g_heap++ = g_DOEXIT_XT; g_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> ; "
|
|
" : < ( a b -- a<b ) - 0< ; "
|
|
" : > ( 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 ; "
|
|
" : 1+ 1 + ; : 1- 1 - ; "
|
|
" : 2* 2 * ; : 2/ 2 / ; "
|
|
|
|
// System Dependent
|
|
" : cell+ ( n -- n ) cell + ; "
|
|
" : cells ( n -- n ) cell * ; "
|
|
" : cell/ ( n -- n ) cell / ; "
|
|
" : aligned ( a -- a ) cell 1 - dup >r + r> invert and ; "
|
|
" : align here aligned here - allot ; "
|
|
" : bye 0 sysexit ; "
|
|
|
|
// Compilation State
|
|
" : [ 0 state ! ; immediate "
|
|
" : ] -1 state ! ; immediate "
|
|
|
|
// Compile to Dictionary
|
|
" : , here ! cell allot ; "
|
|
" : c, here c! 1 allot ; "
|
|
|
|
// Quoting Words
|
|
" : ' bl parse find ; "
|
|
" : ['] ' aliteral ; immediate "
|
|
" : char bl parse 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 "
|
|
" : while ['] 0branch , here 0 , swap ; immediate "
|
|
" : repeat ['] branch , , here swap ! ; immediate "
|
|
" : aft drop ['] branch , here 0 , here swap ; immediate "
|
|
|
|
// Compound words requiring conditionals
|
|
" : min 2dup < if drop else nip then ; "
|
|
" : max 2dup < if nip else drop then ; "
|
|
" : abs ( n -- +n ) dup 0< if negate then ; "
|
|
|
|
// Postpone - done here so we have ['] and IF
|
|
" : >flags ( xt -- flags ) cell - ; "
|
|
" : immediate? ( xt -- f ) >flags @ 1 and 0= 0= ; "
|
|
" : postpone ' dup immediate? if , else aliteral ['] , , then ; immediate "
|
|
|
|
// Counted Loops
|
|
" : for postpone >r postpone begin ; immediate "
|
|
" : next postpone donext , ; immediate "
|
|
" : 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 , ; "
|
|
|
|
// Stack Convience
|
|
" sp@ constant sp0 "
|
|
" rp@ constant rp0 "
|
|
" : depth ( -- n ) sp@ sp0 - cell/ ; "
|
|
|
|
// 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> ; "
|
|
" ' throw 'throw ! "
|
|
|
|
// Examine Dictionary
|
|
" : >name ( xt -- a n ) 3 cells - dup @ swap over aligned - swap ; "
|
|
" : >link ( xt -- a ) 2 cells - @ ; "
|
|
" : >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 see. >link dup 0= until drop cr ; "
|
|
|
|
// Memory Access
|
|
" : COUNT ( b -- b +n ) DUP 1 + SWAP C@ ; "
|
|
//" : HERE ( -- a ) CP @ ; "
|
|
" : PAD ( -- a ) HERE 80 + ; "
|
|
" : CMOVE ( b b u -- ) "
|
|
" FOR AFT >R DUP C@ R@ C! 1 + R> 1 + THEN NEXT 2DROP ; "
|
|
" : FILL ( b u c -- ) "
|
|
" SWAP FOR SWAP AFT 2DUP C! 1 + THEN NEXT 2DROP ; "
|
|
" : -TRAILING ( b u -- b u ) "
|
|
" FOR AFT BL OVER R@ + C@ < "
|
|
" IF R> 1 + EXIT THEN THEN "
|
|
" NEXT 0 ; "
|
|
|
|
// Numeric Output
|
|
" VARIABLE HLD "
|
|
" : DIGIT ( u -- c ) 9 OVER < 7 AND + 48 + ; "
|
|
" : EXTRACT ( n base -- n c ) 0 SWAP UM/MOD SWAP DIGIT ; "
|
|
" : <# ( -- ) PAD HLD ! ; "
|
|
" : HOLD ( c -- ) HLD @ 1 - DUP HLD ! C! ; "
|
|
" : # ( u -- u ) BASE @ EXTRACT HOLD ; "
|
|
" : #S ( u -- 0 ) BEGIN # DUP WHILE REPEAT ; "
|
|
" : SIGN ( n -- ) 0< IF 45 HOLD THEN ; "
|
|
" : #> ( w -- b u ) DROP HLD @ PAD OVER - ; "
|
|
" : str ( n -- b u ) DUP >R ABS <# #S R> SIGN #> ; "
|
|
" : HEX ( -- ) 16 BASE ! ; "
|
|
" : DECIMAL ( -- ) 10 BASE ! ; "
|
|
" : U. ( u -- ) "
|
|
" ( Display an unsigned integer in free format.) "
|
|
" <# #S #> ( convert unsigned number) "
|
|
" SPACE ( print one leading space) "
|
|
" TYPE ; ( print number) "
|
|
" : . ( w -- ) "
|
|
" ( Display an integer in free format, preceeded by a space.) "
|
|
" BASE @ 10 XOR ( if not in decimal mode) "
|
|
" IF U. EXIT THEN ( print unsigned number) "
|
|
" str SPACE TYPE ; ( print signed number if decimal) "
|
|
" : ? ( a -- ) "
|
|
" ( Display the contents in a memory cell.) "
|
|
" @ . ; ( very simple but useful command) "
|
|
|
|
// ( Strings )
|
|
" : $. r@ dup cell+ swap @ type r> dup @ aligned + cell+ >r ; "
|
|
" : .\" [char] \" parse postpone $. dup , 0 do dup c@ c, 1+ loop drop align ; immediate "
|
|
" : $@ r@ dup cell+ swap @ r> dup @ aligned + cell+ >r ; "
|
|
" : s\" [char] \" parse postpone $@ dup , 0 do dup c@ c, 1+ loop drop align ; immediate "
|
|
|
|
// ( Input )
|
|
" : accept ( a n -- n ) 0 swap begin 2dup < while "
|
|
" key dup nl = if 2drop nip exit then "
|
|
" >r rot r> over c! 1+ -rot swap 1+ swap repeat drop nip ; "
|
|
" 200 constant input-limit "
|
|
" : tib ( -- a ) 'tib @ ; "
|
|
" create input-buffer input-limit allot "
|
|
" : tib-setup input-buffer 'tib ! ; "
|
|
" : refill tib-setup tib input-limit accept #tib ! 0 >in ! -1 ; "
|
|
|
|
// ( REPL )
|
|
" : prompt .\" ok\" cr ; "
|
|
" : eval-line begin >in @ #tib @ < while eval1 repeat ; "
|
|
" : query begin ['] eval-line catch if .\" ERROR\" cr then prompt refill drop again ; "
|
|
" : ok .\" uEForth\" cr prompt refill drop query ; "
|
|
" ok "
|
|
;
|
|
|
|
static cell_t *g_heap;
|
|
static const char *g_tib;
|
|
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_throw = 0;
|
|
static cell_t g_DOLIT_XT;
|
|
static cell_t g_DOEXIT_XT;
|
|
|
|
static cell_t convert(const char *pos, cell_t n, cell_t *ret) {
|
|
*ret = 0;
|
|
cell_t negate = 0;
|
|
if (!n) { return 0; }
|
|
if (pos[0] == '-') { negate = -1; ++pos; --n; }
|
|
for (; n; --n) {
|
|
uintptr_t d = pos[0] - '0';
|
|
if (d > 9) {
|
|
d &= 95;
|
|
d -= 7;
|
|
if (d < 10) { return 0; }
|
|
}
|
|
if (d >= (uintptr_t) g_base) { return 0; }
|
|
*ret = *ret * g_base + d;
|
|
++pos;
|
|
}
|
|
if (negate) { *ret = -*ret; }
|
|
return -1;
|
|
}
|
|
|
|
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(const char *name, cell_t len) {
|
|
cell_t *pos = g_last;
|
|
cell_t clen = CELL_LEN(len);
|
|
while (pos) {
|
|
if (len == pos[-3] &&
|
|
same(name, (const char *) &pos[-3 - clen], len) == 0) {
|
|
return (cell_t) pos;
|
|
}
|
|
pos = (cell_t *) pos[-2]; // Follow link
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
static void create(const char *name, cell_t length, cell_t flags, void *op) {
|
|
memcpy(g_heap, name, length); // name
|
|
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
|
|
}
|
|
|
|
static cell_t parse(cell_t sep, cell_t *ret) {
|
|
while (g_tin < g_ntib && g_tib[g_tin] == sep) { ++g_tin; }
|
|
*ret = (cell_t) (g_tib + g_tin);
|
|
while (g_tin < g_ntib && g_tib[g_tin] != sep) { ++g_tin; }
|
|
cell_t len = g_tin - (*ret - (cell_t) g_tib);
|
|
if (g_tin < g_ntib) { ++g_tin; }
|
|
return len;
|
|
}
|
|
|
|
static cell_t *eval1(cell_t *sp, cell_t *call) {
|
|
*call = 0;
|
|
cell_t name;
|
|
cell_t len = parse(' ', &name);
|
|
cell_t xt = find((const char *) name, len);
|
|
if (xt) {
|
|
if (g_state && !(((cell_t *) xt)[-1] & 1)) { // bit 0 of flags is immediate
|
|
*g_heap++ = xt;
|
|
} else {
|
|
*call = xt;
|
|
}
|
|
} else {
|
|
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 {
|
|
*++sp = -1;
|
|
*call = g_throw;
|
|
#if 0
|
|
fprintf(stderr, "Bad Word: ");
|
|
fwrite((const char *) name, 1, len, stderr);
|
|
fprintf(stderr, "\n");
|
|
exit(1);
|
|
#endif
|
|
}
|
|
}
|
|
return sp;
|
|
}
|
|
|
|
int main(int argc, char *argv[]) {
|
|
g_heap = malloc(HEAP_SIZE);
|
|
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;
|
|
udcell_t ud;
|
|
cell_t tmp;
|
|
#define X(name, op, code) create(name, sizeof(name) - 1, name[0] == ';', && op);
|
|
OPCODE_LIST
|
|
#undef X
|
|
g_last[-1] = 1; // Make ; IMMEDIATE
|
|
g_DOLIT_XT = FIND("DOLIT");
|
|
g_DOEXIT_XT = FIND("EXIT");
|
|
ip = g_heap;
|
|
*g_heap++ = FIND("EVAL1");
|
|
*g_heap++ = FIND("BRANCH");
|
|
*g_heap++ = (cell_t) ip;
|
|
g_tib = boot;
|
|
NEXT;
|
|
#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 *) *(cell_t *) (w + sizeof(cell_t)); NEXT;
|
|
OP_DOCOL: *++rp = (cell_t) ip; ip = (cell_t *) (w + sizeof(cell_t)); NEXT;
|
|
}
|