forth-cpu

1
/* 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

181