mirth/mirth.c

/* Mirth -- Minimalist Joy language interpreter.

   Copyright © 2016 Eric Bavier <bavier@member.fsf.org>

   This is free software licensed under the terms of the GNU GPL
   version 3, or at your option, any later version. */
#include <stdio.h>
#include <ctype.h>

#define HEAP_SIZE 5000
#define STACK_SIZE 100
#define CONTINUATION_SIZE 100
#define VARS_SIZE 128

struct var {
  int immediate;
  void * val;
};

/* TODO: Maintain the stack and continuation from the same chunk of
   memory, where the two move in from each end.  This would work both
   for programs that need a large stack but small continuation and
   programs that need a large continuation but relatively small
   stack. */
static void * stack_base[STACK_SIZE];
static void * continuation_base[CONTINUATION_SIZE];
static void ** stack = stack_base - 1;
static void ** continuation = continuation_base - 1;
static struct var vars[VARS_SIZE];

#define push(s,e) *(++s) = ((void *)(e))
#define pop(v)  v = (typeof(v))*(stack--)
#define pop2(t,s) do{ t = (typeof(t))*(stack--); s = (typeof(s))*(stack--); } while(0)
#define popi(i) i = unpack_int(*(stack--))

/* Only two types in Mirth: 1) quotes, and 2) immediate integers.
   They are distinguished by the least-significant bit (lsb).  Quotes
   will always have 0 in the lsb, and immediate integers will always
   have 1.  Quotes are allocated 4-byte-aligned, so the next bit can
   be used for marking during garbage-collection. */
#define quote_p(v) (!((int)(v) & 1))

#define pack_int(c) ((void *)(((c)<<1)|1))
#define unpack_int(v) ((int)(v)>>1)
/* This should look like a quote and behave as expected for "123[]+++" */
#define null 0

typedef struct cell_s * cell_t;
struct cell_s {
  void * car;
  cell_t cdr;
};

/* The heap is where all HEAP_SIZE cells are stored. */
static struct cell_s heap[HEAP_SIZE];
static cell_t free_list = heap;

void heap_init() {
  /* Link all heap cells.  Assumes the compiler inits memory to 0. */
  cell_t cell = heap;
  while (cell < heap + HEAP_SIZE)
    cell = cell->cdr = cell+1;
}

int gc()
{
}

cell_t alloc_cell() {
  if (free_list == null) {
    gc();
    if (free_list == null) {
      fprintf (stderr, "error: out of heap space\n");
      return NULL;
    }
  }
  cell_t ret = free_list;
  free_list = ret->cdr;
  ret->cdr = null;
  return ret;
}
#define free_cell(c) c->cdr = free_list; free_list = c

cell_t cons (void * head, void * tail) {
  cell_t c = alloc_cell();
  c->car = head; c->cdr = tail;
  return c;
}

int length (cell_t lst) {
  if (lst == null) return 0;
  else return 1 + length(lst->cdr);
}
/* The convention is that the "head" of the list becomes the top of
   the stack.  */
#define do_unstack(lst,base)				\
  do {							\
    int _l = length(lst);				\
    for (base = base + _l; lst != null; lst=lst->cdr)	\
      *base-- = lst->car ;				\
    base += _l;						\
  } while(0)

cell_t listify_stack (void ** top, void ** bottom) {
  cell_t c = null;
  while (bottom <= top)
    c = cons (*bottom++, c);
  return c;
}


cell_t parse_quote (FILE * stream) {
  int c;
  cell_t ret, run, next;
  ret = next = alloc_cell();
  while (1) {
    c = getc(stream);
    if (c == ']') {
      if (ret == next) ret = null;
      else run->cdr = null;
      free_cell(next);
      return ret;
    } else {
      run = next;
      if (c == '[') run->car = (void *)parse_quote(stream);
      else run->car = pack_int(c);
      next = run->cdr = alloc_cell();
    }
  }
}

/* Get the next token from input and put it on the continuation stack.
   Return NULL for end-of-input, the parsed token otherwise. */
void * parse_next (FILE * stream) {
  int c;
  c = getc (stream);
  if (c == '{') {
    /* Skip to the next '}'.  No nesting! */
    while (c != '}') c = getc (stream);
    c = getc (stream);
  }
  if (c == EOF) return NULL;
  
  if (isspace(c)) {
    return parse_next (stream);
  } else if (c == '[') {
    void * q = parse_quote (stream);
    if (q == NULL)
      fprintf (stderr, "error: failed to read quotation\n");
    else return q;
  } else {
    return pack_int(c);
  }
}

#ifdef DEBUG
void print_quote(cell_t);
void print_items(cell_t l) {
  if (l != null) {
    if (quote_p(l->car))
      print_quote ((cell_t)l->car);
    else
      printf ("%d ", unpack_int(l->car));
    print_items ((cell_t)l->cdr);
  }
}
void print_quote(cell_t l) {
  printf ("["); print_items (l); printf ("] ");
}

void print_stack() {
  void ** ptr = stack_base;
  printf ("stack: ");
  while (ptr <= stack)
    {
      if (quote_p(*ptr)) print_quote ((cell_t)*ptr);
      else printf ("%d ", unpack_int(*ptr));
      ++ptr;
    }
  printf ("\n");
}
#endif

/* If input is a primitive operator, perform its function and return
   0, otherwise do nothing and return non-zero. */
int maybe_do_primitive (int c) {
  void * top, * second;
  cell_t l, m;
  
#define binary(op)				\
    do{						\
      int _i, _j;				\
      popi(_j); popi(_i);			\
      push(stack, pack_int(_i op _j));		\
    } while(0)

  switch (c) {
  case '$': top = *stack; push(stack,top); break;	    /* dup */
  case '>': second = *(stack-1); push(stack,second); break; /* over */
  case '%': --stack; break;				    /* pop */
  case '\\':						    /* swap */
    pop2(top,second);
    push(stack,top); push(stack,second);
    break;
  case '!': pop(l); do_unstack(l,continuation); break;
  case '_':
    pop2(l,top);
    push(continuation,top);
    do_unstack(l,continuation); break;
  case '?':
    pop2(l,top); if (top != pack_int(0)) do_unstack(l,continuation);
    break;
  case ':':
    if (quote_p(*stack)) {	/* define immediate */
      pop(l); c = unpack_int((int)l->car);
      pop(vars[c].val); vars[c].immediate = 1;
    } else {			/* define variable */
      popi(c);
      pop(vars[c].val); vars[c].immediate = 0;
    }
    break;
  case ';': popi(c); push(stack,vars[c].val); break;  /* load */
  case '^': push(stack,pack_int(getc(stdin))); break; /* read */
  case '.': popi(c); printf("%d", c); break;	      /* write int */
  case ',':					      /* write char/string */
    if (quote_p(*stack))
      for (pop(l); l != null; l = l->cdr)
	printf("%c", unpack_int(l->car));
    else printf("%c", popi(c));
    break;
  case '`': push(stack,pack_int(quote_p(*stack) ? -1 : 0)); break; /* quote? */
  case '+':
    if (quote_p(*stack)) {	/* cons */
      pop2(top,second);
      push(stack,cons(second,top));
    } else binary(+);		/* addition */
    break;
  case '-':
    if (quote_p(*stack)) {	/* uncons */
      pop(l);
      push(stack,l->car); push(stack,l->cdr);
    } else binary(-);		/* subtraction */
    break;
  case '*':
    if (quote_p(*stack)) {	/* concat */
      pop(top);
      for (pop(l); l != null; l = l->cdr){
	push(stack,l->car);
	push(continuation,pack_int('+'));
      }
      push(stack,top);
    } else binary(*);		/* multiplication */
    break;
  case '/':
    if (quote_p(*stack)) {
      /* TODO: take and drop */
    }
    else binary(/);
    break;
  case '(':			/* stack */
    l = listify_stack(stack, stack_base);
    push(stack,l); break;
  case ')':			/* unstack */
    pop(l);
    stack = stack_base - 1;	/* TODO: collect garbage */
    do_unstack(l,stack); break;
  case '<':			/* lesser? */
    pop2(top,second);
    push(stack,pack_int(top > second ? -1 : 0)); break;
  case '=':			/* eq? */
    pop2(top,second);
    push(stack,pack_int(top == second ? -1 : 0)); break;
  case '~': pop(top); push(stack, pack_int(~(int)top)); break;
  case '|':
    if (quote_p(*stack)) {	/* reverse */
      for (pop(l), m = null; l != null; l = l->cdr)
	m = cons(l->car,m);
      push(stack,m);
    } else binary(|);		/* bitwise or */
    break;
  case '&': binary(&); break;	/* bitwise and */
  case '@':			/* shuffle */
    {
      /* Shuffle 0-indexed (i.e. 0 is top, 1 is second, etc.) stack
	 elements with list of indices, where the left-hand-side is
	 the top.  e.g. "swap" == "[10]@" and "elho[13220]@,,,,," =>
	 hello */
      int max = 0, len = 0;
      for (pop(l); l != null; l = l->cdr, ++len) {
	c = unpack_int(l->car) - 48;
	push(continuation,*(stack-c));
	max = (c > max) ? c : max;
      }
      stack -= ++max;	     /* adjust stack based on largest index */
      for (; len; --len)     /* shunt shuffled elements to stack */
	push(stack,*continuation--);
      break;
    }
  case '\'': pop(top); push(stack,cons(top,null)); break; /* unit */
  case '0' ... '9': push(stack,pack_int(c-48)); break;
  default: return 1;
  }
#undef binary
  return 0;
}

/* Immediate variables are assumed to be quotes.  They can be bound to
   any of the characters [a-zA-Z].  When a character that has been
   defined as an immediate is encountered, its quote is immediately
   executed.  E.g. "[[hello],][H]:H" prints "hello" to stdout.
   Primitives may not be redefined as immediates; their primitive
   definitions always take precendence. */
int maybe_do_immediate (int c) {
  if ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))
    if (vars[c].immediate) {
      cell_t v = vars[c].val;
      do_unstack(v,continuation);
      return 0;
    }
  return 1;
}

int eval (FILE * stream) {
#ifdef DEBUG
  print_stack();
#endif
  void * c;
  if (continuation < continuation_base) { /* empty? */
    if ((c = parse_next (stream)) == NULL)
      return 0;			/* EOF */
  } else c = *continuation--;
  if (quote_p(c)) push(stack,c);
  else {
    if (maybe_do_primitive(unpack_int(c))
	&& maybe_do_immediate(unpack_int(c)))
      push(stack,c);
  }
  eval (stream);		/* loop */
}

int main (int argc, char ** argv) {
  FILE * stream;

  heap_init();
  stream = fopen ("prelude.mrth","r");
  eval (stream);
  fclose (stream);

  if (argc > 1) stream = fopen (argv[1],"r");
  else stream = stdin;
  eval (stream);
  fclose (stream);
  return 0;
}