tanks/cforf.c

753 lines
15 KiB
C
Raw Normal View History

/* forf: a crappy Forth implementation
* Copyright (C) 2010 Adam Glasgall
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
/* Notes
* -------------------------------------------------------
*
* This is intended to be implemented as a library. As such, it doesn't
* use the libc memory allocation functions. This may be a different
* programming style than you're used to.
*
* There are two data types: numbers and stacks. Because we can't
* allocate memory, stacks are implemented with begin and end markers
* and not new stack types.
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "cforf.h"
#include "dump.h"
#ifndef max
#define max(a,b) (((a) > (b)) ? (a) : (b))
#define min(a,b) (((a) < (b)) ? (a) : (b))
#endif
char *forf_error_str[] = {
"None",
"Runtime",
"Parse",
"Underflow",
"Overflow",
"Type",
"No such procedure",
"Divide by zero",
};
/*
*
* Memory manipulation
*
*/
void
forf_memory_init(struct forf_memory *m,
long *values,
size_t size)
{
m->mem = values;
m->size = size;
}
/*
*
* Stack manipulation
*
*/
void
forf_stack_init(struct forf_stack *s,
struct forf_value *values,
size_t size)
{
s->stack = values;
s->size = size;
s->top = 0;
}
void
forf_stack_reset(struct forf_stack *s)
{
s->top = 0;
}
size_t
forf_stack_len(struct forf_stack *s)
{
return s->top;
}
int
forf_stack_push(struct forf_stack *s, struct forf_value *v)
{
if (s->top == s->size) {
return 0;
}
s->stack[(s->top)++] = *v;
return 1;
}
int
forf_stack_pop(struct forf_stack *s, struct forf_value *v)
{
if (0 == s->top) {
return 0;
}
*v = s->stack[--(s->top)];
return 1;
}
void
forf_stack_copy(struct forf_stack *dst, struct forf_stack *src)
{
int top = min(dst->size, src->top);
dst->top = top;
memcpy(dst->stack, src->stack, sizeof(*dst->stack) * top);
}
void
forf_stack_reverse(struct forf_stack *s)
{
struct forf_value val;
size_t pos;
for (pos = 0; pos < (s->top)/2; pos += 1) {
size_t qos = s->top - pos - 1;
val = s->stack[pos];
s->stack[pos] = s->stack[qos];
s->stack[qos] = val;
}
}
long
forf_pop_num(struct forf_env *env)
{
struct forf_value val;
if (! forf_stack_pop(env->data, &val)) {
env->error = forf_error_underflow;
return 0;
}
if (forf_type_number != val.type) {
forf_stack_push(env->data, &val);
env->error = forf_error_type;
return 0;
}
return val.v.i;
}
void
forf_push_num(struct forf_env *env, long i)
{
struct forf_value val;
val.type = forf_type_number;
val.v.i = i;
if (! forf_stack_push(env->data, &val)) {
env->error = forf_error_overflow;
}
}
/* Pop an entire stack
*
* DANGER WILL ROBINSON
*
* This returned stack points to values on the data stack. You must be
* finished with this stack before you push anything onto the data
* stack, otherwise your returned stack will be corrupted.
*/
struct forf_stack
forf_pop_stack(struct forf_env *env)
{
struct forf_stack s = { 0, 0, NULL };
struct forf_value val;
size_t depth = 1;
if (! forf_stack_pop(env->data, &val)) {
env->error = forf_error_underflow;
return s;
}
if (forf_type_stack_end != val.type) {
forf_stack_push(env->data, &val);
env->error = forf_error_type;
return s;
}
/* Duplicate just the stack onto s. Begin with -1 to account for the
end of list marker. */
s.size = -1;
while (depth) {
s.size += 1;
if (! forf_stack_pop(env->data, &val)) {
/* You should never underflow here, there should at least be a
stack begin marker. */
env->error = forf_error_runtime;
s.size = 0;
return s;
}
switch (val.type) {
case forf_type_stack_end:
depth += 1;
break;
case forf_type_stack_begin:
depth -= 1;
break;
2010-07-19 17:23:30 -06:00
default:
break;
}
}
s.top = s.size;
s.stack = (env->data->stack) + (env->data->top + 1);
return s;
}
/* Push an entire stack onto another stack.
*/
int
forf_push_stack(struct forf_stack *dst, struct forf_stack *src)
{
struct forf_value val;
while (forf_stack_pop(src, &val)) {
if (! forf_stack_push(dst, &val)) {
return 0;
}
}
return 1;
}
/* Push an entire stack onto the command stack.
*
* This is meant to work with the return value from forf_pop_stack.
*/
int
forf_push_to_command_stack(struct forf_env *env, struct forf_stack *src)
{
if (! forf_push_stack(env->command, src)) {
env->error = forf_error_overflow;
return 0;
}
return 1;
}
/* Move one value from src to dst. Note that one value could mean a
* whole substack, in which case dst gets the stack in reverse! dst can
* also be NULL, in which case a value is just discarded.
*
* Because of the reversing thing, it's important to make sure that the
* data stack is either src or dst. This way, the data stack will
* always have "reversed" substacks, and everything else will have them
* in the right order.
*/
int
forf_stack_move_value(struct forf_env *env,
struct forf_stack *dst,
struct forf_stack *src)
{
struct forf_value val;
size_t depth = 0;
do {
/* Pop from src */
if (! forf_stack_pop(env->command, &val)) {
env->error = forf_error_underflow;
return 0;
}
/* Push to dst (or discard if dst is NULL) */
if (dst) {
if (! forf_stack_push(env->data, &val)) {
env->error = forf_error_overflow;
return 0;
}
}
/* Deal with it being a substack marker */
switch (val.type) {
case forf_type_stack_begin:
depth += 1;
break;
case forf_type_stack_end:
depth -= 1;
break;
2010-07-19 17:23:30 -06:00
default:
break;
}
} while (depth > 0);
return 1;
}
/*
*
* Procedures
*
*/
#define unproc(name, op) \
static void \
forf_proc_ ## name(struct forf_env *env) \
{ \
long a = forf_pop_num(env); \
\
forf_push_num(env, op a); \
}
unproc(inv, ~)
unproc(not, !)
#define binproc(name, op) \
static void \
forf_proc_ ## name(struct forf_env *env) \
{ \
long a = forf_pop_num(env); \
long b = forf_pop_num(env); \
\
forf_push_num(env, b op a); \
}
binproc(add, +)
binproc(sub, -)
binproc(mul, *)
binproc(and, &)
binproc(or, |)
binproc(xor, ^)
binproc(lshift, <<)
binproc(rshift, >>)
binproc(gt, >)
binproc(ge, >=)
binproc(lt, <)
binproc(le, <=)
binproc(eq, ==)
binproc(ne, !=)
static void
forf_proc_div(struct forf_env *env)
{
long a = forf_pop_num(env);
long b = forf_pop_num(env);
if (0 == a) {
env->error = forf_error_divzero;
return;
}
forf_push_num(env, b / a);
}
static void
forf_proc_mod(struct forf_env *env)
{
long a = forf_pop_num(env);
long b = forf_pop_num(env);
if (0 == a) {
env->error = forf_error_divzero;
return;
}
forf_push_num(env, b % a);
}
static void
forf_proc_abs(struct forf_env *env)
{
forf_push_num(env, abs(forf_pop_num(env)));
}
static void
forf_proc_dup(struct forf_env *env)
{
long a = forf_pop_num(env);
forf_push_num(env, a);
forf_push_num(env, a);
}
static void
forf_proc_pop(struct forf_env *env)
{
forf_pop_num(env);
}
static void
forf_proc_exch(struct forf_env *env)
{
long a = forf_pop_num(env);
long b = forf_pop_num(env);
forf_push_num(env, a);
forf_push_num(env, b);
}
static void
forf_proc_if(struct forf_env *env)
{
struct forf_stack ifclause = forf_pop_stack(env);
long cond = forf_pop_num(env);
if (cond) {
forf_push_to_command_stack(env, &ifclause);
}
}
static void
forf_proc_ifelse(struct forf_env *env)
{
struct forf_stack elseclause = forf_pop_stack(env);
struct forf_stack ifclause = forf_pop_stack(env);
long cond = forf_pop_num(env);
if (cond) {
forf_push_to_command_stack(env, &ifclause);
} else {
forf_push_to_command_stack(env, &elseclause);
}
}
static void
forf_proc_memset(struct forf_env *env)
{
long pos = forf_pop_num(env);
long a = forf_pop_num(env);
if (pos >= env->memory->size) {
env->error = forf_error_overflow;
return;
}
env->memory->mem[pos] = a;
}
static void
forf_proc_memget(struct forf_env *env)
{
long pos = forf_pop_num(env);
if (pos >= env->memory->size) {
env->error = forf_error_overflow;
return;
}
forf_push_num(env, env->memory->mem[pos]);
}
/*
*
* Lexical environment
*
*/
struct forf_lexical_env forf_base_lexical_env[] = {
{"~", forf_proc_inv},
{"!", forf_proc_not},
{"+", forf_proc_add},
{"-", forf_proc_sub},
{"*", forf_proc_mul},
{"/", forf_proc_div},
{"%", forf_proc_mod},
{"&", forf_proc_and},
{"|", forf_proc_or},
{"^", forf_proc_xor},
{"<<", forf_proc_lshift},
{">>", forf_proc_rshift},
{">", forf_proc_gt},
{">=", forf_proc_ge},
{"<", forf_proc_lt},
{"<=", forf_proc_le},
{"=", forf_proc_eq},
{"<>", forf_proc_ne},
{"abs", forf_proc_abs},
{"dup", forf_proc_dup},
{"pop", forf_proc_pop},
{"exch", forf_proc_exch},
{"if", forf_proc_if},
{"ifelse", forf_proc_ifelse},
{"mset", forf_proc_memset},
{"mget", forf_proc_memget},
{NULL, NULL}
};
/** Extend a lexical environment */
int
forf_extend_lexical_env(struct forf_lexical_env *dest,
struct forf_lexical_env *src,
size_t size)
{
int base, i;
for (base = 0; dest[base].name; base += 1);
for (i = 0; (base+i < size) && (src[i].name); i += 1) {
dest[base+i] = src[i];
}
if (base + i == size) {
/* Not enough room */
return 0;
}
dest[base+i].name = NULL;
dest[base+i].proc = NULL;
return 1;
}
/*
*
* Parsing
*
*/
static int
forf_push_token(struct forf_env *env, char *token, size_t tokenlen)
{
long i;
char s[MAX_TOKEN_LEN + 1];
char *endptr;
struct forf_value val;
/* Zero-length token yields int:0 from strtol */
/* NUL-terminate it */
memcpy(s, token, tokenlen);
s[tokenlen] = '\0';
/* Try to make in an integer */
i = strtol(s, &endptr, 0);
if ('\0' == *endptr) {
/* Was an int */
val.type = forf_type_number;
val.v.i = i;
} else {
/* If not an int, a procedure name */
val.type = forf_type_proc;
for (i = 0; NULL != env->lenv[i].name; i += 1) {
if (0 == strcmp(s, env->lenv[i].name)) {
val.v.p = env->lenv[i].proc;
break;
}
}
if (NULL == env->lenv[i].name) {
env->error = forf_error_noproc;
return 0;
}
}
if (! forf_stack_push(env->command, &val)) {
env->error = forf_error_overflow;
return 0;
}
return 1;
}
/* Parse an input stream onto the command stack */
int
forf_parse_stream(struct forf_env *env,
forf_getch_func *getch,
void *datum)
{
int running = 1;
long pos = 0;
char token[MAX_TOKEN_LEN];
size_t tokenlen = 0;
struct forf_value val;
size_t stack_depth = 0;
int comment = 0;
#define _tokenize() \
do { \
if (tokenlen) { \
if (! forf_push_token(env, token, tokenlen)) return pos; \
tokenlen = 0; \
} \
} while (0)
while (running) {
int c;
c = getch(datum);
pos += 1;
/* Handle comments */
if (comment) {
if (')' == c) {
comment = 0;
}
continue;
}
switch (c) {
case EOF:
running = 0;
break;
case '(':
comment = 1;
break;
case ' ':
case '\f':
case '\n':
case '\r':
case '\t':
case '\v':
_tokenize();
break;
case '{':
_tokenize();
val.type = forf_type_stack_begin;
if (! forf_stack_push(env->command, &val)) {
env->error = forf_error_overflow;
return pos;
}
stack_depth += 1;
break;
case '}':
_tokenize();
val.type = forf_type_stack_end;
if (! forf_stack_push(env->command, &val)) {
env->error = forf_error_overflow;
return pos;
}
stack_depth -= 1;
break;
default:
if (tokenlen < sizeof(token)) {
token[tokenlen++] = c;
}
break;
}
}
_tokenize();
if (0 != stack_depth) {
env->error = forf_error_parse;
return pos;
}
// The first thing we read should be the first thing we do
forf_stack_reverse(env->command);
return 0;
}
struct forf_char_stream {
char *buf;
size_t len;
size_t pos;
};
static int
forf_string_getch(struct forf_char_stream *stream)
{
if (stream->pos >= stream->len) {
return EOF;
}
return stream->buf[stream->pos++];
}
int
forf_parse_buffer(struct forf_env *env,
char *buf,
size_t len)
{
struct forf_char_stream stream;
stream.buf = buf;
stream.len = len;
stream.pos = 0;
return forf_parse_stream(env, (forf_getch_func *)forf_string_getch, &stream);
}
int
forf_parse_string(struct forf_env *env,
char *str)
{
return forf_parse_buffer(env, str, strlen(str));
}
int
forf_parse_file(struct forf_env *env,
FILE *f)
{
return forf_parse_stream(env, (forf_getch_func *)fgetc, f);
}
/*
*
* Forf environment
*
*/
void
forf_env_init(struct forf_env *env,
struct forf_lexical_env *lenv,
struct forf_stack *data,
struct forf_stack *cmd,
struct forf_memory *mem,
void *udata)
{
env->lenv = lenv;
env->data = data;
env->command = cmd;
env->memory = mem;
env->udata = udata;
}
int
forf_eval_once(struct forf_env *env)
{
struct forf_value val;
if (! forf_stack_pop(env->command, &val)) {
env->error = forf_error_underflow;
return 0;
}
switch (val.type) {
case forf_type_number:
case forf_type_stack_begin:
// Push back on command stack, then move it
forf_stack_push(env->command, &val);
if (! forf_stack_move_value(env, env->data, env->command)) return 0;
break;
case forf_type_proc:
(val.v.p)(env);
break;
default:
env->error = forf_error_runtime;
return 0;
}
return 1;
}
int
forf_eval(struct forf_env *env)
{
int ret;
while (env->command->top) {
ret = forf_eval_once(env);
if ((! ret) || (env->error)) {
return 0;
}
}
return 1;
}