Neale Pickett
·
2024-12-04
forf.c
1/* forf: a crappy Forth implementation
2 * Copyright (C) 2010 Adam Glasgall
3 *
4 * This program is free software: you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation, either version 3 of the License, or
7 * (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program. If not, see <http://www.gnu.org/licenses/>.
16 */
17
18/* Notes
19 * -------------------------------------------------------
20 *
21 * This is intended to be implemented as a library. As such, it doesn't
22 * use the libc memory allocation functions. This may be a different
23 * programming style than you're used to.
24 *
25 * There are two data types: numbers and stacks. Because we can't
26 * allocate memory, stacks are implemented with begin and end markers
27 * and not new stack types.
28 */
29
30#include <limits.h>
31#include <stdio.h>
32#include <stdlib.h>
33#include <string.h>
34
35#include "dump.h"
36#include "forf.h"
37
38#ifndef max
39#define max(a, b) (((a) > (b)) ? (a) : (b))
40#define min(a, b) (((a) < (b)) ? (a) : (b))
41#endif
42
43char *forf_error_str[] = {
44 "None", "Runtime", "Parse", "Underflow", "Overflow",
45 "Type", "No such procedure", "Divide by zero",
46};
47
48/*
49 *
50 * Memory manipulation
51 *
52 */
53void forf_memory_init(struct forf_memory *m, long *values, size_t size) {
54 m->mem = values;
55 m->size = size;
56}
57
58/*
59 *
60 * Stack manipulation
61 *
62 */
63
64void forf_stack_init(struct forf_stack *s, struct forf_value *values,
65 size_t size) {
66 s->stack = values;
67 s->size = size;
68 s->top = 0;
69}
70
71void forf_stack_reset(struct forf_stack *s) { s->top = 0; }
72
73size_t forf_stack_len(struct forf_stack *s) { return s->top; }
74
75int forf_stack_push(struct forf_stack *s, struct forf_value *v) {
76 if (s->top == s->size) {
77 return 0;
78 }
79 s->stack[(s->top)++] = *v;
80 return 1;
81}
82
83int forf_stack_pop(struct forf_stack *s, struct forf_value *v) {
84 if (0 == s->top) {
85 return 0;
86 }
87 *v = s->stack[--(s->top)];
88 return 1;
89}
90
91void forf_stack_copy(struct forf_stack *dst, struct forf_stack *src) {
92 int top = min(dst->size, src->top);
93
94 dst->top = top;
95 memcpy(dst->stack, src->stack, sizeof(*dst->stack) * top);
96}
97
98void forf_stack_reverse(struct forf_stack *s) {
99 struct forf_value val;
100 size_t pos;
101
102 for (pos = 0; pos < (s->top) / 2; pos += 1) {
103 size_t qos = s->top - pos - 1;
104
105 val = s->stack[pos];
106 s->stack[pos] = s->stack[qos];
107 s->stack[qos] = val;
108 }
109}
110
111long forf_pop_num(struct forf_env *env) {
112 struct forf_value val;
113
114 if (!forf_stack_pop(env->data, &val)) {
115 env->error = forf_error_underflow;
116 return 0;
117 }
118 if (forf_type_number != val.type) {
119 forf_stack_push(env->data, &val);
120 env->error = forf_error_type;
121 return 0;
122 }
123 return val.v.i;
124}
125
126void forf_push_num(struct forf_env *env, long i) {
127 struct forf_value val;
128
129 val.type = forf_type_number;
130 val.v.i = i;
131 if (!forf_stack_push(env->data, &val)) {
132 env->error = forf_error_overflow;
133 }
134}
135
136/* Pop an entire stack
137 *
138 * DANGER WILL ROBINSON
139 *
140 * This returned stack points to values on the data stack. You must be
141 * finished with this stack before you push anything onto the data
142 * stack, otherwise your returned stack will be corrupted.
143 */
144struct forf_stack forf_pop_stack(struct forf_env *env) {
145 struct forf_stack s = {0, 0, NULL};
146 struct forf_value val;
147 size_t depth = 1;
148
149 if (!forf_stack_pop(env->data, &val)) {
150 env->error = forf_error_underflow;
151 return s;
152 }
153 if (forf_type_stack_end != val.type) {
154 forf_stack_push(env->data, &val);
155 env->error = forf_error_type;
156 return s;
157 }
158 /* Duplicate just the stack onto s. Begin with -1 to account for the
159 end of list marker. */
160 s.size = -1;
161 while (depth) {
162 s.size += 1;
163 if (!forf_stack_pop(env->data, &val)) {
164 /* You should never underflow here, there should at least be a
165 stack begin marker. */
166 env->error = forf_error_runtime;
167 s.size = 0;
168 return s;
169 }
170 switch (val.type) {
171 case forf_type_stack_end:
172 depth += 1;
173 break;
174 case forf_type_stack_begin:
175 depth -= 1;
176 break;
177 default:
178 break;
179 }
180 }
181 s.top = s.size;
182 s.stack = (env->data->stack) + (env->data->top + 1);
183 return s;
184}
185
186/* Push an entire stack onto another stack.
187 */
188int forf_push_stack(struct forf_stack *dst, struct forf_stack *src) {
189 struct forf_value val;
190
191 while (forf_stack_pop(src, &val)) {
192 if (!forf_stack_push(dst, &val)) {
193 return 0;
194 }
195 }
196 return 1;
197}
198
199/* Push an entire stack onto the command stack.
200 *
201 * This is meant to work with the return value from forf_pop_stack.
202 */
203int forf_push_to_command_stack(struct forf_env *env, struct forf_stack *src) {
204 if (!forf_push_stack(env->command, src)) {
205 env->error = forf_error_overflow;
206 return 0;
207 }
208 return 1;
209}
210
211/* Move one value from src to dst. Note that one value could mean a
212 * whole substack, in which case dst gets the stack in reverse! dst can
213 * also be NULL, in which case a value is just discarded.
214 *
215 * Because of the reversing thing, it's important to make sure that the
216 * data stack is either src or dst. This way, the data stack will
217 * always have "reversed" substacks, and everything else will have them
218 * in the right order.
219 */
220int forf_stack_move_value(struct forf_env *env, struct forf_stack *dst,
221 struct forf_stack *src) {
222 struct forf_value val;
223 size_t depth = 0;
224
225 do {
226 /* Pop from src */
227 if (!forf_stack_pop(env->command, &val)) {
228 env->error = forf_error_underflow;
229 return 0;
230 }
231
232 /* Push to dst (or discard if dst is NULL) */
233 if (dst) {
234 if (!forf_stack_push(env->data, &val)) {
235 env->error = forf_error_overflow;
236 return 0;
237 }
238 }
239
240 /* Deal with it being a substack marker */
241 switch (val.type) {
242 case forf_type_stack_begin:
243 depth += 1;
244 break;
245 case forf_type_stack_end:
246 depth -= 1;
247 break;
248 default:
249 break;
250 }
251 } while (depth > 0);
252
253 return 1;
254}
255
256/*
257 *
258 * Procedures
259 *
260 */
261
262#define unproc(name, op) \
263 static void forf_proc_##name(struct forf_env *env) { \
264 long a = forf_pop_num(env); \
265 \
266 forf_push_num(env, op a); \
267 }
268
269unproc(inv, ~) unproc(not, !)
270
271#define binproc(name, op) \
272 static void forf_proc_##name(struct forf_env *env) { \
273 long a = forf_pop_num(env); \
274 long b = forf_pop_num(env); \
275 \
276 forf_push_num(env, b op a); \
277 }
278
279 binproc(add, +) binproc(sub, -) binproc(mul, *) binproc(and, &)
280 binproc(or, |) binproc(xor, ^) binproc(lshift, <<) binproc(rshift, >>)
281 binproc(gt, >) binproc(ge, >=) binproc(lt, <) binproc(le, <=)
282 binproc(eq, ==) binproc(ne, !=)
283
284 static void forf_proc_div(struct forf_env *env) {
285 long a = forf_pop_num(env);
286 long b = forf_pop_num(env);
287
288 if (0 == a || (a == -1 && b == LONG_MIN)) {
289 env->error = forf_error_divzero;
290 return;
291 }
292 forf_push_num(env, b / a);
293}
294
295static void forf_proc_mod(struct forf_env *env) {
296 long a = forf_pop_num(env);
297 long b = forf_pop_num(env);
298
299 if (0 == a || (a == -1 && b == LONG_MIN)) {
300 env->error = forf_error_divzero;
301 return;
302 }
303 forf_push_num(env, b % a);
304}
305
306static void forf_proc_abs(struct forf_env *env) {
307 forf_push_num(env, abs(forf_pop_num(env)));
308}
309
310static void forf_proc_dup(struct forf_env *env) {
311 long a = forf_pop_num(env);
312
313 forf_push_num(env, a);
314 forf_push_num(env, a);
315}
316
317static void forf_proc_pop(struct forf_env *env) { forf_pop_num(env); }
318
319static void forf_proc_exch(struct forf_env *env) {
320 long a = forf_pop_num(env);
321 long b = forf_pop_num(env);
322
323 forf_push_num(env, a);
324 forf_push_num(env, b);
325}
326
327static void forf_proc_if(struct forf_env *env) {
328 struct forf_stack ifclause = forf_pop_stack(env);
329 long cond = forf_pop_num(env);
330
331 if (cond) {
332 forf_push_to_command_stack(env, &ifclause);
333 }
334}
335
336static void forf_proc_ifelse(struct forf_env *env) {
337 struct forf_stack elseclause = forf_pop_stack(env);
338 struct forf_stack ifclause = forf_pop_stack(env);
339 long cond = forf_pop_num(env);
340
341 if (cond) {
342 forf_push_to_command_stack(env, &ifclause);
343 } else {
344 forf_push_to_command_stack(env, &elseclause);
345 }
346}
347
348static void forf_proc_memset(struct forf_env *env) {
349 long pos = forf_pop_num(env);
350 long a = forf_pop_num(env);
351
352 if (pos >= env->memory->size) {
353 env->error = forf_error_overflow;
354 return;
355 }
356
357 env->memory->mem[pos] = a;
358}
359
360static void forf_proc_memget(struct forf_env *env) {
361 long pos = forf_pop_num(env);
362
363 if (pos >= env->memory->size) {
364 env->error = forf_error_overflow;
365 return;
366 }
367
368 forf_push_num(env, env->memory->mem[pos]);
369}
370
371/*
372 *
373 * Lexical environment
374 *
375 */
376struct forf_lexical_env forf_base_lexical_env[] = {{"~", forf_proc_inv},
377 {"!", forf_proc_not},
378 {"+", forf_proc_add},
379 {"-", forf_proc_sub},
380 {"*", forf_proc_mul},
381 {"/", forf_proc_div},
382 {"%", forf_proc_mod},
383 {"&", forf_proc_and},
384 {"|", forf_proc_or},
385 {"^", forf_proc_xor},
386 {"<<", forf_proc_lshift},
387 {">>", forf_proc_rshift},
388 {">", forf_proc_gt},
389 {">=", forf_proc_ge},
390 {"<", forf_proc_lt},
391 {"<=", forf_proc_le},
392 {"=", forf_proc_eq},
393 {"<>", forf_proc_ne},
394 {"abs", forf_proc_abs},
395 {"dup", forf_proc_dup},
396 {"pop", forf_proc_pop},
397 {"exch", forf_proc_exch},
398 {"if", forf_proc_if},
399 {"ifelse", forf_proc_ifelse},
400 {"mset", forf_proc_memset},
401 {"mget", forf_proc_memget},
402 {NULL, NULL}};
403
404/** Extend a lexical environment */
405int forf_extend_lexical_env(struct forf_lexical_env *dest,
406 struct forf_lexical_env *src, size_t size) {
407 int base, i;
408
409 for (base = 0; dest[base].name; base += 1)
410 ;
411 for (i = 0; (base + i < size) && (src[i].name); i += 1) {
412 dest[base + i] = src[i];
413 }
414 if (base + i == size) {
415 /* Not enough room */
416 return 0;
417 }
418 dest[base + i].name = NULL;
419 dest[base + i].proc = NULL;
420 return 1;
421}
422
423/*
424 *
425 * Parsing
426 *
427 */
428static int forf_push_token(struct forf_env *env, char *token, size_t tokenlen) {
429 long i;
430 char s[MAX_TOKEN_LEN + 1];
431 char *endptr;
432 struct forf_value val;
433
434 /* Zero-length token yields int:0 from strtol */
435
436 /* NUL-terminate it */
437 memcpy(s, token, tokenlen);
438 s[tokenlen] = '\0';
439
440 /* Try to make in an integer */
441 i = strtol(s, &endptr, 0);
442 if ('\0' == *endptr) {
443 /* Was an int */
444 val.type = forf_type_number;
445 val.v.i = i;
446 } else {
447 /* If not an int, a procedure name */
448 val.type = forf_type_proc;
449 for (i = 0; NULL != env->lenv[i].name; i += 1) {
450 if (0 == strcmp(s, env->lenv[i].name)) {
451 val.v.p = env->lenv[i].proc;
452 break;
453 }
454 }
455 if (NULL == env->lenv[i].name) {
456 env->error = forf_error_noproc;
457 return 0;
458 }
459 }
460
461 if (!forf_stack_push(env->command, &val)) {
462 env->error = forf_error_overflow;
463 return 0;
464 }
465
466 return 1;
467}
468
469/* Parse an input stream onto the command stack */
470int forf_parse_stream(struct forf_env *env, forf_getch_func *getch,
471 void *datum) {
472 int running = 1;
473 long pos = 0;
474 char token[MAX_TOKEN_LEN];
475 size_t tokenlen = 0;
476 struct forf_value val;
477 size_t stack_depth = 0;
478 int comment = 0;
479
480#define _tokenize() \
481 do { \
482 if (tokenlen) { \
483 if (!forf_push_token(env, token, tokenlen)) \
484 return pos; \
485 tokenlen = 0; \
486 } \
487 } while (0)
488
489 while (running) {
490 int c;
491
492 c = getch(datum);
493 pos += 1;
494
495 /* Handle comments */
496 if (comment) {
497 switch (c) {
498 case EOF:
499 env->error = forf_error_parse;
500 return pos;
501 case ')':
502 comment = 0;
503 break;
504 }
505 continue;
506 }
507
508 switch (c) {
509 case EOF:
510 running = 0;
511 break;
512 case '(':
513 comment = 1;
514 break;
515 case ' ':
516 case '\f':
517 case '\n':
518 case '\r':
519 case '\t':
520 case '\v':
521 _tokenize();
522 break;
523 case '{':
524 _tokenize();
525 val.type = forf_type_stack_begin;
526 if (!forf_stack_push(env->command, &val)) {
527 env->error = forf_error_overflow;
528 return pos;
529 }
530 stack_depth += 1;
531 break;
532 case '}':
533 _tokenize();
534 val.type = forf_type_stack_end;
535 if (!forf_stack_push(env->command, &val)) {
536 env->error = forf_error_overflow;
537 return pos;
538 }
539 stack_depth -= 1;
540 break;
541 default:
542 if (tokenlen < sizeof(token)) {
543 token[tokenlen++] = c;
544 }
545 break;
546 }
547 }
548 _tokenize();
549
550 if (0 != stack_depth) {
551 env->error = forf_error_parse;
552 return pos;
553 }
554
555 // The first thing we read should be the first thing we do
556 forf_stack_reverse(env->command);
557
558 return 0;
559}
560
561struct forf_char_stream {
562 char *buf;
563 size_t len;
564 size_t pos;
565};
566
567static int forf_string_getch(struct forf_char_stream *stream) {
568 if (stream->pos >= stream->len) {
569 return EOF;
570 }
571 return stream->buf[stream->pos++];
572}
573
574int forf_parse_buffer(struct forf_env *env, char *buf, size_t len) {
575 struct forf_char_stream stream;
576
577 stream.buf = buf;
578 stream.len = len;
579 stream.pos = 0;
580
581 return forf_parse_stream(env, (forf_getch_func *)forf_string_getch, &stream);
582}
583
584int forf_parse_string(struct forf_env *env, char *str) {
585 return forf_parse_buffer(env, str, strlen(str));
586}
587
588int forf_parse_file(struct forf_env *env, FILE *f) {
589 return forf_parse_stream(env, (forf_getch_func *)fgetc, f);
590}
591
592/*
593 *
594 * Forf environment
595 *
596 */
597
598void forf_env_init(struct forf_env *env, struct forf_lexical_env *lenv,
599 struct forf_stack *data, struct forf_stack *cmd,
600 struct forf_memory *mem, void *udata) {
601 env->lenv = lenv;
602 env->data = data;
603 env->command = cmd;
604 env->memory = mem;
605 env->udata = udata;
606}
607
608int forf_eval_once(struct forf_env *env) {
609 struct forf_value val;
610
611 if (!forf_stack_pop(env->command, &val)) {
612 env->error = forf_error_underflow;
613 return 0;
614 }
615 switch (val.type) {
616 case forf_type_number:
617 case forf_type_stack_begin:
618 // Push back on command stack, then move it
619 forf_stack_push(env->command, &val);
620 if (!forf_stack_move_value(env, env->data, env->command))
621 return 0;
622 break;
623 case forf_type_proc:
624 (val.v.p)(env);
625 break;
626 default:
627 env->error = forf_error_runtime;
628 return 0;
629 }
630 return 1;
631}
632
633int forf_eval(struct forf_env *env) {
634 int ret;
635
636 env->error = forf_error_none;
637 while (env->command->top) {
638 ret = forf_eval_once(env);
639 if ((!ret) || (env->error)) {
640 return 0;
641 }
642 }
643 return 1;
644}