| 1 |
5 |
howe.r.j.8 |
/* H2 Forth Virtual Machine, Richard James Howe, 2017-2019, MIT License */
|
| 2 |
|
|
#include <assert.h>
|
| 3 |
|
|
#include <errno.h>
|
| 4 |
|
|
#include <stdarg.h>
|
| 5 |
|
|
#include <stdint.h>
|
| 6 |
|
|
#include <stdio.h>
|
| 7 |
|
|
#include <stdlib.h>
|
| 8 |
|
|
#include <string.h>
|
| 9 |
|
|
|
| 10 |
|
|
#define STK (64)
|
| 11 |
|
|
#define USE_HEX_IN (0)
|
| 12 |
|
|
#define USE_HEX_OUT (1)
|
| 13 |
|
|
|
| 14 |
|
|
typedef uint16_t m_t;
|
| 15 |
|
|
typedef int16_t s_t;
|
| 16 |
|
|
typedef uint32_t d_t;
|
| 17 |
|
|
typedef struct forth_t { m_t m[32768], vs[STK], rs[STK], pc, t, rp, sp, cpu; } forth_t;
|
| 18 |
|
|
typedef int (*cb)(forth_t *h, void *param);
|
| 19 |
|
|
|
| 20 |
|
|
static inline size_t cells(forth_t const * const h) {
|
| 21 |
|
|
assert(h);
|
| 22 |
|
|
return sizeof(h->m)/sizeof(h->m[0]);
|
| 23 |
|
|
}
|
| 24 |
|
|
|
| 25 |
|
|
static void die(const char *fmt, ...) {
|
| 26 |
|
|
assert(fmt);
|
| 27 |
|
|
va_list arg;
|
| 28 |
|
|
va_start(arg, fmt);
|
| 29 |
|
|
vfprintf(stderr, fmt, arg);
|
| 30 |
|
|
va_end(arg);
|
| 31 |
|
|
fputc('\n', stderr);
|
| 32 |
|
|
exit(EXIT_FAILURE);
|
| 33 |
|
|
}
|
| 34 |
|
|
|
| 35 |
|
|
static FILE *fopen_or_die(const char *file, const char *mode) {
|
| 36 |
|
|
assert(file && mode);
|
| 37 |
|
|
FILE *h = NULL;
|
| 38 |
|
|
errno = 0;
|
| 39 |
|
|
if (!(h = fopen(file, mode)))
|
| 40 |
|
|
die("file open %s (mode %s) failed: %s", file, mode, strerror(errno));
|
| 41 |
|
|
return h;
|
| 42 |
|
|
}
|
| 43 |
|
|
|
| 44 |
|
|
static int save(forth_t *h, const char *name, const size_t start, const size_t length) {
|
| 45 |
|
|
assert(h);
|
| 46 |
|
|
if (!name || !(((length - start) <= length) && ((start + length) <= cells(h))))
|
| 47 |
|
|
return -69; /* open-file IOR */
|
| 48 |
|
|
FILE *out = fopen(name, "wb");
|
| 49 |
|
|
if (!out)
|
| 50 |
|
|
return -69; /* open-file IOR */
|
| 51 |
|
|
int r = 0;
|
| 52 |
|
|
for (size_t i = start; i < length; i++) {
|
| 53 |
|
|
if (USE_HEX_OUT) {
|
| 54 |
|
|
fprintf(out, "%02x%02x\n", ((unsigned)(h->m[i] >> 8) & 255u), (unsigned)(h->m[i] >> 0) & 255u);
|
| 55 |
|
|
} else {
|
| 56 |
|
|
if (fputc(h->m[i]&255, out) < 0 || fputc(h->m[i]>>8, out) < 0)
|
| 57 |
|
|
r = -76; /* write-file IOR */
|
| 58 |
|
|
}
|
| 59 |
|
|
}
|
| 60 |
|
|
return fclose(out) < 0 ? -62 /* close-file IOR */ : r;
|
| 61 |
|
|
}
|
| 62 |
|
|
|
| 63 |
|
|
static int load(forth_t *h, const char *name) {
|
| 64 |
|
|
assert(h && name);
|
| 65 |
|
|
FILE *input = fopen_or_die(name, "rb");
|
| 66 |
|
|
long r = 0;
|
| 67 |
|
|
for (size_t i = 0; i < cells(h); i++, r = i) {
|
| 68 |
|
|
if (USE_HEX_IN) {
|
| 69 |
|
|
unsigned d = 0;
|
| 70 |
|
|
if (fscanf(input, "%x", &d) != 1) {
|
| 71 |
|
|
r = -1;
|
| 72 |
|
|
break;
|
| 73 |
|
|
}
|
| 74 |
|
|
h->m[i] = d;
|
| 75 |
|
|
} else {
|
| 76 |
|
|
int c1 = 0, c2 = 0;
|
| 77 |
|
|
if ((c1 = fgetc(input)) < 0 || (c2 = fgetc(input)) < 0)
|
| 78 |
|
|
break;
|
| 79 |
|
|
h->m[i] = ((c1 & 0xffu)) | ((c2 & 0xffu) << 8u);
|
| 80 |
|
|
}
|
| 81 |
|
|
}
|
| 82 |
|
|
fclose(input);
|
| 83 |
|
|
return r < 64 ? -70 /* read-file IOR */ : 0; /* minimum size checks, 128 bytes */
|
| 84 |
|
|
}
|
| 85 |
|
|
|
| 86 |
|
|
static inline void trace(FILE *out, m_t opt, m_t *m, m_t pc, m_t instruction, m_t t, m_t rp, m_t sp) {
|
| 87 |
|
|
(void)m;
|
| 88 |
|
|
if (!(opt & 1))
|
| 89 |
|
|
return;
|
| 90 |
|
|
fprintf(out, "[ %4x %4x %4x %2x %2x ]\n", pc-1, instruction, t, rp, sp);
|
| 91 |
|
|
}
|
| 92 |
|
|
|
| 93 |
|
|
static int run(forth_t *h, m_t opt, FILE *in, FILE *out, const char *block, cb func, void *param) {
|
| 94 |
|
|
assert(h && in && out);
|
| 95 |
|
|
static const m_t delta[] = { 0, 1, -2, -1 };
|
| 96 |
|
|
const m_t l = cells(h);
|
| 97 |
|
|
m_t *const m = h->m, *const vs = h->vs, *const rs = h->rs;
|
| 98 |
|
|
m_t pc = h->pc, t = h->t, rp = h->rp, sp = h->sp, cpu = h->cpu, r = 0;
|
| 99 |
|
|
for (;;) {
|
| 100 |
|
|
const m_t instruction = m[pc++];
|
| 101 |
|
|
trace(out, opt, m, pc, instruction, t, rp, sp);
|
| 102 |
|
|
if ((r = -!(sp < STK && rp < STK && pc < l))) /* critical error */
|
| 103 |
|
|
goto finished;
|
| 104 |
|
|
if (0x8000 & instruction) { /* literal */
|
| 105 |
|
|
vs[++sp % STK] = t;
|
| 106 |
|
|
t = instruction & 0x7FFF;
|
| 107 |
|
|
} else if ((0xE000 & instruction) == 0x6000) { /* ALU */
|
| 108 |
|
|
m_t n = vs[sp % STK], T = t;
|
| 109 |
|
|
pc = (instruction & 0x10) ? rs[rp % STK] >> 1 : pc;
|
| 110 |
|
|
switch ((instruction >> 8u) & 0x1f) {
|
| 111 |
|
|
case 0: break;
|
| 112 |
|
|
case 1: T = n; break;
|
| 113 |
|
|
case 2: T += n; break;
|
| 114 |
|
|
case 3: T &= n; break;
|
| 115 |
|
|
case 4: T |= n; break;
|
| 116 |
|
|
case 5: T ^= n; break;
|
| 117 |
|
|
case 6: T = ~t; break;
|
| 118 |
|
|
case 7: T = -(t == n); break;
|
| 119 |
|
|
case 8: T = -((s_t)n < (s_t)t); break;
|
| 120 |
|
|
case 9: T = n >> t; break;
|
| 121 |
|
|
case 10: T--; break;
|
| 122 |
|
|
case 11: T = rs[rp % STK]; break;
|
| 123 |
|
|
case 12: T = m[(t>>1)%l]; break;
|
| 124 |
|
|
case 13: T = n << t; break;
|
| 125 |
|
|
case 14: T = sp; break;
|
| 126 |
|
|
case 15: T = -(n < t); break;
|
| 127 |
|
|
case 16: cpu = t; T = n; break;
|
| 128 |
|
|
case 17: T = cpu; break;
|
| 129 |
|
|
case 18: T = rp; break;
|
| 130 |
|
|
case 19: T = -(t == 0); break;
|
| 131 |
|
|
case 20: T = 0xD1ED; /* CPU-ID */ break;
|
| 132 |
|
|
case 21: T = instruction & 0x7FFF; break; /* lit: internal use only */
|
| 133 |
|
|
/* 22: UNUSED */
|
| 134 |
|
|
/* 23: UNUSED */
|
| 135 |
|
|
/* 24: UNUSED */
|
| 136 |
|
|
/* Hosted instructions only */
|
| 137 |
|
|
case 25: if (opt & 2) { T = save(h, block, n>>1, ((d_t)T+1)>>1); } break;
|
| 138 |
|
|
case 26: if (opt & 2) { T = fputc(t, out); } break;
|
| 139 |
|
|
case 27: if (opt & 2) { T = fgetc(in); } break;
|
| 140 |
|
|
case 28: if (opt & 2) { if (rs[rp % STK]) { rs[rp % STK] = 0; sp--; r = t; t = n; goto finished; }; T = t; } break;
|
| 141 |
|
|
case 29: if (opt & 2) { T = opt; opt = T; } break;
|
| 142 |
|
|
case 30: if (opt & 2) { if (func) { T = func(h, param); } else { pc=4; T=21; } } break;
|
| 143 |
|
|
/* 31: UNUSED */
|
| 144 |
|
|
default: if (opt & 2) { pc=4; T=21; } break;
|
| 145 |
|
|
}
|
| 146 |
|
|
sp += delta[ instruction & 0x3];
|
| 147 |
|
|
rp += delta[(instruction >> 2) & 0x3];
|
| 148 |
|
|
if (instruction & 0x80)
|
| 149 |
|
|
vs[sp % STK] = t;
|
| 150 |
|
|
if (instruction & 0x40)
|
| 151 |
|
|
rs[rp % STK] = t;
|
| 152 |
|
|
if (instruction & 0x20)
|
| 153 |
|
|
m[(t >> 1) % l] = n;
|
| 154 |
|
|
t = T;
|
| 155 |
|
|
} else if (0x4000 & instruction) { /* call */
|
| 156 |
|
|
rs[++rp % STK] = pc << 1;
|
| 157 |
|
|
pc = instruction & 0x1FFF;
|
| 158 |
|
|
} else if (0x2000 & instruction) { /* 0branch */
|
| 159 |
|
|
pc = !t ? instruction & 0x1FFF : pc;
|
| 160 |
|
|
t = vs[sp-- % STK];
|
| 161 |
|
|
} else { /* branch */
|
| 162 |
|
|
pc = instruction & 0x1FFF;
|
| 163 |
|
|
}
|
| 164 |
|
|
}
|
| 165 |
|
|
finished: h->pc = pc, h->t = t, h->rp = rp, h->sp = sp, h->cpu = cpu;
|
| 166 |
|
|
return (s_t)r;
|
| 167 |
|
|
}
|
| 168 |
|
|
|
| 169 |
|
|
int main(int argc, char **argv) {
|
| 170 |
|
|
static forth_t h = { .m = { 0 }, .vs = { 0 }, .rs = { 0 } };
|
| 171 |
|
|
if (argc > 4)
|
| 172 |
|
|
die("usage: %s [in.blk] [out.blk] [file.fth]", argv[0]);
|
| 173 |
|
|
if (load(&h, argc < 2 ? "embed.blk" : argv[1]) < 0)
|
| 174 |
|
|
die("embed: load failed");
|
| 175 |
|
|
FILE *in = argc <= 3 ? stdin : fopen_or_die(argv[3], "rb");
|
| 176 |
|
|
if (run(&h, 2, in, stdout, argc < 3 ? NULL : argv[2], NULL, NULL))
|
| 177 |
|
|
die("embed: run failed");
|
| 178 |
|
|
return 0; /* exiting takes care of closing files, freeing memory */
|
| 179 |
|
|
}
|
| 180 |
|
|
|
