forf.c

/* 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 <limits.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include "dump.h"
#include "forf.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;
    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;
    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 || (a == -1 && b == LONG_MIN)) {
    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 || (a == -1 && b == LONG_MIN)) {
    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) {
      switch (c) {
      case EOF:
        env->error = forf_error_parse;
        return pos;
      case ')':
        comment = 0;
        break;
      }
      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;

  env->error = forf_error_none;
  while (env->command->top) {
    ret = forf_eval_once(env);
    if ((!ret) || (env->error)) {
      return 0;
    }
  }
  return 1;
}