/*
 * mm.c : the Mutt Machine
 *  Craig Durland 6/87
 *    Added dstrings, more comments	3/91
 *    lists, ojbect manager		mid '91
 *  See mm2.doc for lots of documentation.
 */

/* Copyright 1990, 1991, 1992 Craig Durland
 *   Distributed under the terms of the GNU General Public License.
 *   Distributed "as is", without warranties of any kind, but comments,
 *     suggestions and bug reports are welcome.
 */

static char what[] = "@(#)MM2 (Mutt Machine II) v2.0 2/2/92";

#include <stdio.h>
#include <setjmp.h>
#include <os.h>
#include <const.h>
#include "opcode.h"
#include "mm.h"
#include "oman.h"

extern char *calloc(), *malloc(), *strcpy(), *strcat(), *l_to_a();
extern long atol();

char *MMvtoa();

typedef struct
{
   uint8 type;
   union { uint16 t; char *name; maddr addr; } token;
   int abase, vsptr;	/* part of the stack frame */
} ositem;

MMDatum RV, TV;			/* Mutt Machine registers */

/* ******************************************************************** */
/* ************************ Object Management ************************* */
/* ******************************************************************** */

static int is_object();

#define IS_STRING(type) (((type) == STRING) || ((type) == OSTRING))
#define MAKE_STRING(rv)	\
  (((rv).type == OSTRING) ? OBJSTRING((rv).val.object) : (rv).val.str)


extern Object *OMcreate_object(), *OMextract_elements(),
	      *OMdup_object(), *OMnth_element();
extern ObjectPool *OMcreate_object_pool();

	/* ********** local objects **************** */
#define MAX_LOCAL_OBJECTS ASTACKSIZ

static ObjectPool *local_object_pool, *tmp_object_pool;

static Object *local_object_table[MAX_LOCAL_OBJECTS];
static int lobj_max = 0, lobj_start = 0;

static void lobj_push(object) Object *object;
{
  if (lobj_max == MAX_LOCAL_OBJECTS) MMbitch("Object table overflow");
  local_object_table[lobj_max++] = object;
}

static Object *get_lobj(n) int n;
  { return local_object_table[lobj_start + n]; }


    /* Routine to gc local objects.
     * All live local objects are marked.
     * If RV is an object and is in the local pool, need to mark it also.
     * Notes:
     *   It would be easier to mark dead objects (don't have to mess with
     *     RV) but I don't know where the dead objects are in
     *     local_object_table[] - lobj_start and lobj_max reflect the
     *     current live range.
     *   Worrying about RV being in the local pool stinks - the only time it
     *     will matter is if a program is returning a (local) object when we
     *     gc.  Then only time this regularly happens is when all programs
     *     are done and then it only matters if the application wants the
     *     object.  Most of the time a OSTRING is sitting in RV that nobody
     *     cares about.  Unfortunately, I don't know of a easy/fast way to
     *     get around these problems.
     */
static int local_gc_marker()
{
  int j;

  if (is_object(RV.type) && OMin_pool(local_object_pool, RV.val.object))
	OMgc_mark_object(RV.val.object);

  for (j = lobj_max; j--; ) OMgc_mark_object(local_object_table[j]);

  return 1;		/* live objects are marked */
}

	/* ********** global objects **************** */

static ObjectPool *global_object_pool;

Object **MMglobal_object_table;		/* Object *MMglobal_object_table[]; */

static void gobj_push(object, n) Object *object;
{
  MMglobal_object_table[n] = object;
}

    /* Routine to gc global objects.
     * I only gc a block when the block is freed (since global objects live
     *   as long as the block does.  When the block is freed, I need to free
     *   up all objects in the block.
     * Input:
     *   object_table:  Pointer to the block (being freed) object table.
     *   num_objects:  Number of object in object_table.
     * Notes:
     *   Call this when a block is freed.
     *   All global objects are in the same object pool.
     *   Only gc when a block is freed because thats the only time there
     *     will be garbage in this pool.  So don't GC when run out of memory
     *     or when somebody gc's the world.
     *   I mark all dead objects (the ones in the block object table)
     *     because thats easy.
     */
static void gc_globals(object_table, num_objects) Object *object_table[];
{
  int j;

  if (num_objects == 0) return;		/* avoid unnecessary work */

  for (j = num_objects; j--; ) OMgc_mark_object(object_table[j]);

  OMgc_pool(global_object_pool, 2);	/* dead objects are marked */
}

	/* ****************** Object Utilities ******************* */
    /* Is type an object type?
     * Notes:
     *   If type is STRING and points into a OSTRING, we are screwed.  I
     *     don't think I do this however.
     */
static int is_object(type) int type;
{
  return (type == OSTRING || type == LIST);
}

    /* !!!
     * Notes:
     *   I call OMset_object() alot and don't check for errors.  This is bad
     *     but I'm real tired of error checking right now.  Besides, only a
     *     few cases will cause problems and if there are errors, they will
     *     be out of memory problems - in which case not much is working
     *     anyway (probably).  And these are "soft" failures - the data
     *     types don't change and the data is valid, just wrong.  Could make
     *     for some fun Mutt debugging.
     *     Yes, I plan to fix it one of these years.  Or I will avoid it by
     *       rewriting this stuff yet again.
     * !!!
     */

	/* !!! no workie much */
static Object *convert_to_object(pool, val) ObjectPool *pool; MMDatum *val;
{
  int type;
  Object *object;

  type = val->type;
  if (is_object(type)) return val->val.object;

  if (type == STRING) type = OSTRING;
  if (!(object = OMcreate_object(pool, type, 0))) return NULL;
  switch (type)
  {
    case NUMBER:  OMset_object(object, type, (long int)val->val.num); break;
    case OSTRING: OMset_object(object, type,           val->val.str); break;
    default: return NULL;
  }
  return object;
}

	/* !!! no workie much */
void MMconvert_to_datum(object, val) Object *object; MMDatum *val;
{
  int type;

  type = object->type;
  switch (type)
  {
    case NUMBER:  val->val.num = OBJNUMBER(object); break;
    case LIST:
    case OSTRING:
	val->val.object = object; break;
  }
  val->type = type;
}

/* ******************************************************************** */
/* *************** Stack Management *********************************** */
/* ******************************************************************** */

extern int MMask_pgm;

static MMStkFrame *prev_stkframe;
static int vsptr, asptr, osptr, abase, vbase, numargs;

static ositem opstack[OSTACKSIZ];		/* opcode stack */
static MMDatum argstack[ASTACKSIZ];		/* arg stack */
static uint8  varstack[VSTACKSIZ];		/* flotsam, vars and jetsam */

static maddr pc;			/* MM program counter */

uint8 *MMglobal_vars;		/* start of global variables */

#define asp() asptr
#define aspset(n) asptr = (n)

    /* Initialize the Mutt Machine.  Set all state variables, stacks, etc to
     *   their initial state.
     * Notes
     *   This MUST be called before the first pgm is run.
     *   Call when a pgm aborts or halts.
     *   Don't need to call this a pgm is done because poping the stack last
     *     stack frame will restore things to this state.
     */
static void init_stacks()
{
  asptr = osptr = vsptr = abase = vbase = numargs = 0;
  prev_stkframe = NULL;

  lobj_max = lobj_start = 0;

  MMglobal_vars = NULL;
  MMglobal_object_table = NULL;
}

    /* Save the current stack frame in mark & set up new a frame. 
     * Notes
     *   Only need to save the global vars (MMglobal_vars and
     *     MMglobal_object_table) when calling an external pgm (via OPNAME)
     *     - in other cases, they don't change.
     */
static void setframe(mark,startframe,flotsam) register MMStkFrame *mark;
{
  mark->abase = abase; mark->startframe = abase = startframe;
  mark->vbase = vbase; mark->vsptr = flotsam;
  mark->numargs = numargs;
  mark->pc = pc;
  mark->prev_stkframe = prev_stkframe;

  prev_stkframe = mark;
  vbase = vsptr;	/* set vbase after flotsam */
  numargs = asp() -abase;

/* ???  instead of putting gvars and global object table in stackframe,
 * why not put in a block pointer and dig it out of there on reset?
 */

  mark->gvars = MMglobal_vars;
  mark->global_object_table = MMglobal_object_table;

  mark->lobj_max = lobj_max; mark->lobj_start = lobj_start;
  lobj_start = lobj_max;
}

static void resetframe(mark)		/* reset a stack frame */
  register MMStkFrame *mark;
{
  aspset(mark->startframe);
  abase = mark->abase; vbase = mark->vbase;
  numargs = mark->numargs;
  pc = mark->pc; vsptr = mark->vsptr;

  MMglobal_vars = mark->gvars;
  MMglobal_object_table = mark->global_object_table;

  lobj_max = mark->lobj_max; lobj_start = mark->lobj_start;
}

static void pop_stkframe()
{
  resetframe(prev_stkframe);
  prev_stkframe = prev_stkframe->prev_stkframe;
}

   /* Don't use this if you turn around and call MM().
    * Set MMask_pgm to TRUE after you do the ask.
    * This is ment for self contained opcodes.
    */
void MMset_ask_frame()
{
  resetframe(prev_stkframe);
  MMask_pgm = (MMask_pgm && numargs);
}

void MMreset_ask_frame()
{
  prev_stkframe->numargs = numargs;
  prev_stkframe->abase = abase;
  MMask_pgm = TRUE;		/* reset (ask-user) */
}

MMgonna_ask_pgm()
{
  return (MMask_pgm && prev_stkframe->numargs);
}

static void vpush(val) MMDatum *val;
{
  if (asptr == ASTACKSIZ) MMbitch("arg stack overflow");
  argstack[asptr++] = *val;
}

static void vpop(val) MMDatum *val; { *val = argstack[--asptr]; }

    /* Pull the nth arg out of the stack frame.
     * This routine for people writing Mutt extensions.  It is used to get
     *   parameters off the stack.  For example, if you are writing the C
     *   code for "foo" and it is called like so:  (foo 123), then when your
     *   foo code is called, you can MMpull_nth_arg(&RV,0) and RV will be a
     *   number with value 123.
     * See also:  MMnext_arg().
     * Notes:
     *   Don't have to worry about garbage collection because I'm just
     *     copying pointers - the objects remain in the local stack and will
     *     not be collected.
     * Input:
     *   val:  Pointer to a var (MMDatum).  Arg will be stashed there.
     *     Usually &RV.
     *   n:  The arg you want to pull.  0 is the first and numargs is 1+
     *     the last (not that it helps you - you have to use (nargs) or
     *     MMpull_nth_arg() until it returns false.
     * Output:
     *   val:  MMDatum is filled in with pointers to nth stack arg.  If it
     *     is an object string, it points to the contents of the string.
     * Returns:
     *   TRUE:  Got to the arg
     *   FALSE:  n if out range (less than 0 or greater than the number of
     *		 args)
     */
MMpull_nth_arg(val,n) MMDatum *val; int n;	/* pull the nth arg */
{
  if (n >= numargs || n < 0) return FALSE;
  *val = argstack[abase+n];

  if (val->type == OSTRING)
  {
    val->type = STRING;
    val->val.str = OBJSTRING(val->val.object);
  }

  return TRUE;
}

    /* Same as MMpull_nth_arg() 'cept no object conversion.  Ment to for
     *   internal consumption.
     */
static int apulln(val,n) MMDatum *val; int n;	/* pull the nth arg */
{
  if (n >= numargs || n < 0) return FALSE;
  *val = argstack[abase+n];

  return TRUE;
}

    /* Get the next arg in the stack frame, convert it to a string and store
     *   it in a buffer.
     * Ment for stuff that wants a bunch of ascii info from something and
     *   does the conversions itself (like (ask)).  Use this routine when
     *   writing a routine that can get info from either a user or Mutt pgm.
     * Input:
     *   buf: Pointer to a area to store the ascii form of the var in.
     * Returns:
     *   FALSE: No more args
     *   TRUE:  all OK
     * Munges:
     *   TV
     * WARNING!
     *   Make sure this does NOT setjmp()!
     */
MMnext_arg(buf) char *buf;	/* ask a pgm instead of user */
{
  if (!MMpull_nth_arg(&TV,0)) { MMmoan("not that many args"); return FALSE; }
  strcpy(buf,MMvtoa(&TV));
  abase++; numargs--;

  return TRUE;
}

static void set_MMvar(ptr,type) uint8 *ptr;	/* var = RV */
{
  switch (type)
  {
    case INT8:
    case BOOLEAN: PUT_UINT8(ptr,RV.val.num);		break;
    case INT16:   PUT_INT16(ptr,RV.val.num);		break;
    case INT32:   PUT_INT32(ptr,RV.val.num);		break;
    case BLOB:    PUT_INT32(ptr,(int32)RV.val.blob);	break;
  }
}

static void get_MMvar(ptr,type) uint8 *ptr;	/* RV = var */
{
  RV.type = type;
  switch (type)
  {
    case INT8:    RV.type = NUMBER; RV.val.num = GET_UINT8(ptr); break;
    case INT16:   RV.type = NUMBER; RV.val.num = GET_INT16(ptr); break;
    case INT32:   RV.type = NUMBER; RV.val.num = GET_INT32(ptr); break;
    case BOOLEAN: RV.val.num = GET_UINT8(ptr);			 break;
    case BLOB:    RV.val.blob = (uint8 *)GET_INT32(ptr);	 break;
  }
}

static uint8 *lalloc(n)		/* alloc n bytes on varstack, 0 == noop */
{
  uint8 *ptr = &varstack[vsptr];

  vsptr += n;
  if (vsptr > VSTACKSIZ) MMbitch("var stack overflow");
  return ptr;
}

static char *pushstr(str) char *str;
{ return strcpy(lalloc(strlen(str) + 1),str); }

static void opush(op) ositem *op;
{
  if (osptr == OSTACKSIZ) MMbitch("opstack overflow");
  opstack[osptr++] = *op;
}

static void opop(op) ositem *op; { *op = opstack[--osptr]; }

/* ******************************************************************** */
/* ****************** Handle imbedded types *************************** */
/* ******************************************************************** */

maddr pcat() { return pc; }

static maddr addr()	/* grab relative addr at pc, advance the pc */
{
  maddr a = pc +GET_INT16(pc + 1);
  pc += sizeof(int16);
  return a;
}

static int num8()	/* grab a uint8 at the pc, advance the pc */
{
  int n = GET_UINT8(pc + 1);	/* assumes no sign extension ie 0xFF => 255 */
  pc += sizeof(uint8);
  return n;
}

static int num16()	/* grab a int16 at the pc, advance the pc */
{
  int n = GET_INT16(pc + 1);
  pc += sizeof(int16);
  return n;
}

static int32 num32()	/* grab a int32 at the pc, advance the pc */
{
  int32 n = GET_INT32(pc + 1);
  pc += sizeof(int32);
  return n;
}

#define STR() (char *)(MMglobal_vars -num16())

/* ******************************************************************** */
/* ****************** the Mutt Machine  ******************************* */
/* ******************************************************************** */

void MMabort_pgm();

static void exetern(), dotok(), convert_to();

static int n, n1;
static uint8 *blob;
static ositem op;

char result[RSIZ];	/* A stash to hold STRINGs */
   /* MMask_pgm is initially FALSE so when pgms aren't running the outside
    *   world won't get confused.
    */
int MMask_pgm = FALSE;

#define opcode() *pc
#define incpc()   pc++

    /* Reset the Mutt Machine.
     * This is called when no Mutt programs are running ie when the last
     *   program has finished running.  It resets the stacks, garbage
     *   collects MM and the application and general clean up to make ready
     *   for the next program to run.
     * Notes:
     *   If a program stops and leaves a (local) object in RV, it is not
     *     GCed.  This is because an application may want to see the result
     *     of running a program.  ??? I'm not sure this is a good idea.  The
     *     object should be GCed when the next program runs and only cause a
     *     problem with big objects.
     * Input:
     *   aborting:  TRUE if this is being called because MM is aborting.
     */
static void reset_MM(aborting)
{
  if (aborting)
  {
    init_stacks();
    RV.type = NUMBER;	/* so garbage collecter won't think this is a object */
  }
  MMgc_external_objects();
  OMgc_pool(tmp_object_pool, 1);    /* live (ie none) objects are marked */
  OMgc_pool(local_object_pool, 0);  /* OMgc_the_world(); */
  MMask_pgm = FALSE;
}

    /* The Mutt Machine main loop.
     * Notes
     *   To avoid having to maintain a stack of stack frames, I use
     *     recursion.  This means that I need to save a stack frame (eg for
     *     function calls), I call myself and let C save it for me.
     * Input:
     *   startaddr:  Address of the code to run.  Must have set up a stack
     *     frame (ie all state vars are set to "proper" values).
     * Result:
     *   Side effects up the wazoo.
     */
static void MM(startaddr) maddr startaddr;
{
  MMStkFrame mark;

  pc = startaddr;
  while(TRUE)
  {
    switch(opcode())
    {
      case HALT: MMabort_pgm(0);
      case DONE: goto done;

      case ASKUSER: MMask_pgm = FALSE; RV.type = VOID; break;

      case RVBOOL:  RV.type = BOOLEAN; RV.val.num = num8();  break;
      case RVNUM8:  RV.type = NUMBER;  RV.val.num = num8();  break;
      case RVNUM16: RV.type = NUMBER;  RV.val.num = num16(); break;
      case RVNUM32: RV.type = NUMBER;  RV.val.num = num32(); break;
      case RVSTR:   RV.type = STRING;  RV.val.str = STR();   break;
      case RVVOID:  RV.type = VOID; break;

      case ADD: vpop(&TV); RV.val.num += TV.val.num;		  break;
      case SUB: vpop(&TV); RV.val.num  = TV.val.num - RV.val.num; break;
      case MUL: vpop(&TV); RV.val.num *= TV.val.num;		  break;
/* !!!??? divide by zero exceptable???? core dump */
      case DIV: vpop(&TV); RV.val.num  = TV.val.num / RV.val.num; break;

      case CMP:
	vpop(&TV);
	if (IS_STRING(RV.type))
	  n = (0 == strcmp(MAKE_STRING(RV), MAKE_STRING(TV)));
	else n = (RV.val.num == TV.val.num);

	RV.type = BOOLEAN; RV.val.num = n;
	break;
      case NOT: RV.val.num = !RV.val.num; break;
      case LT:				/* (< x y) => (vpop < RV) */
	vpop(&TV); RV.val.num = (TV.val.num < RV.val.num);  RV.type = BOOLEAN;
	break;
      case LTE:				/* (<= x y) => (vpop <= RV) */
	vpop(&TV); RV.val.num = (TV.val.num <= RV.val.num); RV.type = BOOLEAN;
	break;

      case JMP:		   pc = addr(); continue;
      case JMPTRUE:
        if (RV.val.num)  { pc = addr(); continue; }
	addr();
	break;
      case JMPFALSE:
        if (!RV.val.num) { pc = addr(); continue; }
	addr();
	break;

      case ARG:
	if (!apulln(&RV,(int)RV.val.num))
		MMbitch("(arg n): Not that many args.");
	break;
      case NARGS: RV.type = NUMBER; RV.val.num = numargs; break;
      case PUSHARGS:
	n = RV.val.num;
	while (apulln(&RV,n++)) vpush(&RV);
	break;

      case PUSHRV:
	if (RV.type == STRING && RV.val.str == result)
	  RV.val.str = pushstr(RV.val.str);
	else
	  if (RV.type & OPMASK)		/* setup a fcn call */
	  {
	    switch (op.type = RV.type)
	    {
	      case OPTOKEN:
	      case OPXTOKEN:  op.token.t    = RV.val.num;  break;
	      case OPADDRESS: op.token.addr = RV.val.addr; break;
	      case OPNAME:
		op.token.name = RV.val.str;  /* FADDR ensures not in result */
	    }
	    goto setop;
	  }
	  /* else just shove it */
      case SHOVERV: vpush(&RV); break;
      case DUP: vpop(&TV); vpush(&TV); vpush(&TV); break;
      case POP: vpop(&TV); break;    

      case PUSHTOKEN:
	op.type = OPTOKEN; op.token.t = num16();
  setop:
	op.abase = asp(); op.vsptr = vsptr; opush(&op);
	break;
      case PUSHXT:   op.type = OPXTOKEN;  op.token.t    = num16(); goto setop;
      case PUSHNAME: op.type = OPNAME;    op.token.name = STR();   goto setop;
      case PUSHADDR: op.type = OPADDRESS; op.token.addr = addr();  goto setop;
      case FADDR:
        switch(n = num8())	/* type: one of the OPxxxx code types */
	{
	  case OPTOKEN:
	  case OPXTOKEN:  RV.val.num = num16(); break;
	  case OPADDRESS: RV.val.addr = addr(); break;
	  case OPNAME:		/* RV is STRING or OSTRING */
	    if (RV.type == OSTRING) 	/* protect against GC */
	      RV.val.str = pushstr(OBJSTRING(RV.val.object));
	    else	/* STRING: protect against RV getting munged */
	      if (RV.val.str == result) RV.val.str = pushstr(RV.val.str);
	    break;
	}
	RV.type = n;
	break;

      case DOOP:
	opop(&op); setframe(&mark,op.abase,op.vsptr);
	switch(op.type)
	{
	  case OPADDRESS: MM(op.token.addr); break;
	  case OPTOKEN:   dotok(op.token.t); break;
	  case OPNAME:    RV.type = VOID; exetern(op.token.name); break;
	  case OPXTOKEN:  RV.type = VOID; MMxtoken(op.token.t); break;
	}
	pop_stkframe();
	break;

      case TYPECHECK:
	n = num8();
	if (RV.type != n && !(n == STRING && RV.type == OSTRING))
		MMbitch("Type mismatch");
	break;

      case LALLOC: lalloc(num16()); break;
      case GETLVAR:			     /* (get-local-var type offset) */
        n = num8();	/* type */
	n1 = num16();	/* offset */
	if (n == STRING)	/* compiler should say OSTRING */
	{
	  RV.type = OSTRING;
	  RV.val.object = get_lobj(n1);
	}
	else
	  if (n == LIST)
	  {
	    RV.type = LIST;
	    RV.val.object = get_lobj(n1);
	  }
	  else get_MMvar(&varstack[vbase + n1],n);
	break;
      case GETGVAR:			    /* (get-global-var type offset) */
        n = num8();	/* type */
	n1 = num16();	/* offset */
	if (n == STRING)	/* compiler should say OSTRING */
	{
	  RV.type = OSTRING;
	  RV.val.object = MMglobal_object_table[n1];
	}
	else
	  if (n == LIST)
	  {
	    RV.type = LIST;
	    RV.val.object = MMglobal_object_table[n1];
	  }
	  else  get_MMvar(MMglobal_vars + n1, n);
	break;
      case SETLVAR:			     /* (set-local-var type offset) */
        n = num8();	/* type */
	n1 = num16();	/* offset */ 
	switch(n)
	{
	  case STRING:			/* var is a string object */
	    if (RV.type == STRING)		/* string constant */
	      OMset_object(get_lobj(n1), OSTRING, RV.val.str);
	    else				/* string object */
	      OMset_object(get_lobj(n1), OSTRING, OBJSTRING(RV.val.object));
	    break;
	  case LIST:			/* var is a list object */
	    OMset_object(get_lobj(n1), LIST, RV.val.object);
	    break;
	  default:		/* every other var type */
	    set_MMvar(&varstack[vbase + n1],n);
	    break;
	}
	break;
      case SETGVAR:			    /* (set-global-var type offset) */
        n = num8();	/* type */
	n1 = num16();	/* offset */ 
	switch(n)
	{
	  case STRING:			/* var is a string object */
	    if (RV.type == STRING)		/* string constant */
	      OMset_object(MMglobal_object_table[n1], OSTRING, RV.val.str);
	    else				/* string object */
	      OMset_object(MMglobal_object_table[n1],
		OSTRING, OBJSTRING(RV.val.object));
	    break;
	  case LIST:			/* var is a list object */
	    OMset_object(MMglobal_object_table[n1], LIST, RV.val.object);
	    break;
	  default:		/* every other var type */
	    set_MMvar(MMglobal_vars + n1, n);
	    break;
	}
	break;

      case RVLBASE:
	RV.type = BLOB; RV.val.blob = varstack +vbase +num16(); break;
      case RVGBASE:
        RV.type = BLOB; RV.val.blob = MMglobal_vars +num16();
	break;
      case GETRVAR:				 /* (get-var-relative type) */
	vpop(&TV); get_MMvar(RV.val.blob + TV.val.num,num8()); break;
      case SETRVAR:
	n = num8();		/* type */
	/* !!!  sleeze so I can set object args */
	switch(n)
	{
	  case STRING:
	    vpop(&TV);
	    if (TV.type != OSTRING) MMbitch("set-var-relative:  wanted OSTRING!");
	    if (RV.type == STRING)		/* string constant */
	      OMset_object(TV.val.object, OSTRING, RV.val.str);
	    else				/* string object */
	      OMset_object(TV.val.object, OSTRING, OBJSTRING(RV.val.object));
	    break;
	  case LIST:
	    vpop(&TV);
	    if (TV.type != LIST) MMbitch("set-var-relative:  wanted list!");
	    OMset_object(TV.val.object, LIST, RV.val.object);
	    break;
	  default:
	    vpop(&TV); blob = TV.val.blob; vpop(&TV);
	    set_MMvar(blob + TV.val.num, n);
	}
	break;

      case CREATE_OBJ:	 /* (create-object global/local object-type offset) */
      {
	int global, type, offset;
	Object *object;

	global = num8();
	type = num8();

	offset = num16();

	if (global) object = OMcreate_object(global_object_pool, type, 0);
	else 	    object = OMcreate_object( local_object_pool, type, 0);

	if (!object) MMbitch("No memory to create object!");
	
	if (global) gobj_push(object,offset);
	else lobj_push(object);

	break;
      }
      case LEN_OF:					     /* (length-of) */
	switch (RV.type)
	{
	  case STRING:	RV.val.num = strlen(RV.val.str);	 break;
	  case OSTRING:
	  case LIST:	RV.val.num = OMlength_of(RV.val.object); break;
	  default:	RV.val.num = 0; break;
	}
	RV.type = NUMBER;
	break;
      case CONVERT_TO:					    /* (convert-to) */
	vpop(&TV);			/* type */
	convert_to((int)TV.val.num, &RV);
	break;

      default: MMbitch("Invalid opcode");
    }
    incpc();
  }
done: ;
}

    /* Convert a MM type to another MM type.
     * Valid conversions:
     *   NUMBER to:
     *     STRING or OSTRING:  same as (concat).  eg 123 -> "123"
     *     CHARACTER: 0x33 -> "3"
     *     BOOLEAN: 0 -> FALSE and !0 -> TRUE
     *   OSTRING to:
     *     NUMBER:  "123" -> 123
     *     CHARACTER: "3" -> 0x33
     *     BOOLEAN:  "TRUE" -> TRUE	?????????????????
     *   LIST to:
     *     No valid conversions.
     *   BOOLEAN to:
     *     NUMBER: TRUE -> 1 and FALSE -> 0
     *     STRING: TRUE -> "TRUE"	??????????????????
     *   BLOB to:
     *     No valid conversions.
     *   VOID to:
     *     No valid conversions.
     *   FCNPTR to:
     *     No valid conversions.
     *   
     * Result
     *   val is converted (in place) to type.
     */
static void convert_to(type, val) MMDatum *val;
{
  int vtype = val->type;

  if (type == vtype || (type == OSTRING && IS_STRING(vtype))) return;

  switch(vtype)
  {
    default:
     booboo:
      MMbitch("convert-to:  Invalid conversion.");
      break;
    case NUMBER:
      val->type = STRING;
      switch(type)
      {
	default: goto booboo;
	case OSTRING:
	  val->val.str = l_to_a((long int)val->val.num);
	  break;
	case CHARACTER:
	  result[0] = (char)val->val.num; result[1] = '\0';
	  val->val.str = result;
	  break;
	case BOOLEAN:
	  val->val.num = (val->val.num != 0);
	  val->type = BOOLEAN;
	  break;
      }
      break;
    case STRING:
    case OSTRING:
    {
      char *ptr = MAKE_STRING(*val);

      val->type = type;
      switch(type)
      {
	default: goto booboo;
	case NUMBER:
	  val->val.num = atol(ptr);
	  break;
	case CHARACTER:
	  val->type = NUMBER; val->val.num = ptr[0];
	  break;
      }
      break;
    }
    case BOOLEAN:
      val->type = type;
      switch(type)
      {
	default: goto booboo;
	case NUMBER:
	  val->val.num = (val->val.num != 0);
	  break;
      }
      break;
  }
}

/* ******************************************************************** */
/* ****************** Internal tokens  ******************************** */
/* ******************************************************************** */

    /* Internal tokens are like functions:  they need a stack frame with
     *   args in it.  Stack frames make it possible/easier to deal with
     *   functions that take a unknown number of args or type or need to
     *   diddle with callers (ancestor) stack frames.
     * Drawbacks:  takes time (and code) to create the stack frame.
     */


char *MMvtoa(val) MMDatum *val;			/* MMDatum to ascii */
{
  switch (val->type)
  {
    case BOOLEAN: return val->val.num ? "TRUE" : "FALSE";
    case STRING:  return val->val.str;
    case VOID:    return "VOID";
    case NUMBER:  return l_to_a((long int)val->val.num);
    case OSTRING: return OBJSTRING(val->val.object);
    case LIST:	  return "LIST";
  }
  return "BLOB";
}

void MMconcat()		/* concatenate a bunch of strings or numbers */
{
  register int n = 0;

  *result = '\0';
  while (apulln(&TV,n++)) strcat(result,MMvtoa(&TV));
}

static void mm_ask()
{
  char prompt[RSIZ];

  if (!MMgonna_ask_pgm()) { MMconcat(); strcpy(prompt,result); }
  MMset_ask_frame();
  if (MMask_pgm)			/* grab arg off the arg stack */
    { if (!MMnext_arg(result)) MMabort_pgm(2); }
  else MMask(prompt,result);		/* ask the user */
  RV.type = STRING; RV.val.str = result;
  MMreset_ask_frame();
}

static void substr(string, n,z) char *string; int n,z;
{
  OMnz_magic(strlen(string), &n,&z);
  strcpy(result,&string[n]); result[z] = '\0';

  RV.type = STRING; RV.val.str = result;
}

    /* Input:  RV contains object to extract from
     */
static void extract_em(n,z, atomize) int n,z, atomize;
{
  Object *ptr;

  switch(RV.type)
  {
    default:	 MMbitch("extract-element(s):  invalid type!");
    case STRING: substr(RV.val.str, n,z); break;
    case OSTRING:
    case LIST:
      if (atomize)
      {
	if (ptr = OMnth_element(local_object_pool, RV.val.object, n))
		MMconvert_to_datum(ptr, &RV);
      }
      else
	if (ptr = OMextract_elements(local_object_pool, RV.val.object, n,z))
		RV.val.object = ptr;

      if (!ptr) MMbitch("extract-element(s):  Out of memory!");
  }
}

    /* (insert-object object n new-object new-object ...)
     * Notes:
     *   This can generate lots of garbage (if inserting NUMBERs or STRINGs).
     *   Have to put the garbage in a seprate pool so if a GC is done while
     *     I'm in the middle of the insert, they won't be collected and
     *     cause a core dump.  I'll get rid of them later.  Having the
     *     garbage in a seprate pool also makes it easy to get rid of them
     *     quickly (rather than wait for a big GC - which might be better.
     *     I don't know).
     */
static void insert_object()
{
  int n, z;
  Object *ptr;

  apulln(&RV,0);				/* object */

/* !!! check to make sure is object till compiler can do it for me! */
if (!is_object(RV.type)) MMbitch("insert-object:  Not an object!");

  apulln(&TV,1); n = TV.val.num;		/* n */
  for (z = 2; apulln(&TV, z++); )
  {
/* !!!??? only insert one object because can't know where object ends so can
* insert next object after it
*/
    ptr = convert_to_object(tmp_object_pool, &TV);
    if (!ptr) continue;     /* !!! not convertable or out of mem. Do what? */
    OMinsert_object(RV.val.object, n++, ptr);	/* !!!error check */
  }

	/* free all object in the temp pool */
  OMgc_pool(tmp_object_pool, 1);    /* live (ie none) objects are marked */
}

static void dotok(t)
{
  int n,z;

  switch(t)
  {
    case ASK: mm_ask(); break;				    /* (ask prompt) */
    case MSG:						   /* (msg strings) */
      MMconcat(); MMmsg(result); RV.type = STRING; RV.val.str = result; break;
    case CONCAT:				 /* (concat string num ...) */
      MMconcat(); RV.type = STRING; RV.val.str = result; break;
    case INSERT_OBJ:  /* (insert-object object n new-object new-object ...) */
      insert_object();
      break;
    case EXTRACT_ELS:			   /* (extract-elements object n z) */
      apulln(&RV,0);			/* object */
      apulln(&TV,1); n = TV.val.num;	/* n */
      apulln(&TV,2); z = TV.val.num;	/* z */
      extract_em(n,z, FALSE);
      break;
    case EXTRACT_EL:			      /* (extract-element object n) */
      apulln(&RV,0);			/* object */
      apulln(&TV,1);			/* n */
      extract_em((int)TV.val.num,1, TRUE);
      break;
    case REMOVE_ELS:			    /* (remove-elements object n z) */
      apulln(&RV,0);			/* object */
      apulln(&TV,1); n = TV.val.num;	/* n */
      apulln(&TV,2); z = TV.val.num;	/* z */

      if (is_object(RV.type)) OMremove_items(RV.val.object,n,z);
      else MMbitch("remove-elements:  invalid type!");

      RV.type = VOID;	/* ??? Return removed objects? */

      break;

    default: MMbitch("phooie");
  }
}

/* ******************************************************************** */
/* ****************** The Frontend ************************************ */
/* ******************************************************************** */

extern maddr MMpgm_addr();		/* in mmaux() */

    /* Execute external code.
     * Notes
     *   Might switch blocks ie might need to change the global var and
     *     object table pointers.
     * Input:
     *   name:  name of the pgm to run.
     * Result:
     *   MMglobal_vars and MMglobal_object_table might change.
     */
static void exetern(name) char *name;	/* execute an external something */
{
  int n;

  if ((n = MMpgm_lookup(name)) != -1) MM(MMpgm_addr(n));
  else
    if (!MMaux_fcn(name))
	MMbitch(strcat(strcpy(result,"Can't find pgm: "),name));
}
  
    /* Load a compiled code file and run the code at the entry point.
     * Code file layout:
     *   Header (see mm.h)
     *   Code
     *   Routine names (a bunch of C strings)
     *   Routine addresses
     * Notes:
     *   Need to set MMglobal_vars and MMglobal_object_table because a block
     *     lookup will not be done before we execute the MAIN code.
     *   If I can't add pgms (MMadd_pgm() complains), MMadd_pgm() needs to
     *     clean up whatever it needs to and call MMfree_block().  It can
     *     also just ignore pgms it can't add and return TRUE so that I'll
     *     go ahead and run the init code.  The problem is if there are
     *     global objects and the init code doesn't run, they might not be
     *     initialized.  At some later time a pgm in the block might be run,
     *     use a uninitialized object and the object routines might not know
     *     what to do with it (and bad things could happen).
     *   If we run out of memory or the init code doesn't run (because we
     *     ran out of memory), the global object table might not be
     *     initailized.  If we then try to free the block, we may try to
     *     free garbage and cause all kinds of problems.  A way around this
     *     is to initialize the global object table to NULL which the
     *     garbage collecters can understand (but not all the object
     *     commands can).  The local object table doesn't have this problem
     *     because it only expands as objects are placed into it (hence no
     *     junk in it).
     * Input:
     *   fname : Name of the file that has compiled Mutt code in it.  The
     *     extension is changed to .mco and the application will open it (so
     *     it can do any path searching it wants to).
     *   complain: TRUE if you want me to print a message if fname can't be
     *     opened.  All error messages (memory problems, etc) will always
     *     generate messages.
     * Returns:
     *   NULL : Couldn't open fname, out of memory, the code is out of sync
     *     with this version of MM, etc.
     *   entry_point : the address of the start up code in the loaded block.
     * Munges:
     *   MMglobal_object_table:
     *   MMglobal_vars:
     *     Points to the global var tables for the new block.  Ready to
     *     run the blocks init code.
     * Side effects:
     *   MMset_hooks() is called.
     * !!! Need to check for fread() errors!
     */
#define ABC 150		/* max number of addresses in I can get per read */
maddr MMload_code(fname,complain) char *fname;
{
  extern FILE *MMopen_code_file();

  address z;
  char *block, *nmptr, buf[250];
  FILE *fptr;
  int j, block_id, num_pgms, num_global_objects;
  unsigned int code_size, nmoffset, global_var_space;
  maddr code, entrypt;
  uint8 bytes[ABC*sizeof(address)], *qtr;

  MMglobal_object_table = NULL;
  block = NULL;

		/* open the code file */
  new_ext(buf,fname,".mco");
  if ((fptr = MMopen_code_file(buf)) == NULL)
	{ if (complain) MMmoan("Can't open code file"); return NULL; }

		/* read and parse the header !!! error check*/
  fread((char *)bytes,1,BYTES_IN_HEADER,fptr);

  if (MM_MAGIC_NUMBER != GET_UINT8(&bytes[H_MAGIC_NUMBER]))
    { MMmoan("Versionits - recompile Mutt code."); goto booboo; }

  z =			GET_ADDRESS(&bytes[H_ENTRY_POINT]);
  code_size =		GET_UINT16 (&bytes[H_BYTES_OF_CODE]);
  nmoffset =		GET_UINT16 (&bytes[H_NAME_TABLE_OFFSET]);
  num_pgms =		GET_INT16  (&bytes[H_NUMBER_OF_PGMS]);
  global_var_space =	GET_UINT16 (&bytes[H_BYTES_OF_GVARS]);
  num_global_objects =	GET_UINT16 (&bytes[H_NUM_GLOBAL_OBJECTS]);

	/* take care of global objects: 
	 *   Object *MMglobal_object_table[num_global_objects];
	 * Note:  there may not be any global objects.
	 * Zero out the pointers in case something fails.
	 */
  if (num_global_objects &&
      (MMglobal_object_table =
	(Object **)calloc(num_global_objects, sizeof(Object *))) == NULL)
  {
    MMmoan("Can't allocate global object table");
    goto booboo;
  }
  
	/* calculate size of code, name table and global vars */
  if ((block = malloc(code_size + global_var_space)) == NULL)
  {
    MMmoan("Can't malloc code");
    goto booboo;
  }

     /* Get the code, strings and name table.	 !!! error check */
  fread(block,1,code_size,fptr);
  code		= (maddr)block;
  entrypt	= code + z;
  nmptr		= block + nmoffset;
  MMglobal_vars	= (uint8 *)(block + code_size);

		/* create the block name and block */
  MMblock_name(buf,fname);
  if (-1 ==
	(block_id = MMadd_block(buf,code, MMglobal_vars,
		 MMglobal_object_table, num_global_objects)))
  {
booboo:
    if (MMglobal_object_table) free((char *)MMglobal_object_table);
    if (block)		       free((char *)block);
booboo1:
    fclose(fptr);
    return NULL;
  }

		/* add routine entry points (name, block_id, address) */
  while (num_pgms)
  {
    j = (num_pgms < ABC) ? num_pgms : ABC;	/* read as many as can/left */
    num_pgms -= j; qtr = bytes;
    fread(qtr,sizeof(address),j,fptr);	/* !!! should test for NULL */
    for (; j--; qtr += sizeof(address))
    {
      z = GET_ADDRESS(qtr);	/* offset */
      if (!MMadd_pgm(nmptr, block_id, code + z)) goto booboo1;
      while (*nmptr++ != '\0') ;	/* point to next name */
    }
  }

		/* zero the global vars */
#if 1
  memset((char *)MMglobal_vars, 0, global_var_space);
#else
  for (j = 0; j < global_var_space; j++) MMglobal_vars[j] = 0;
#endif

  fclose(fptr);

  MMset_hooks();

  return entrypt;
}

	/* free the code block allocated in MMload_code() */
void MMfree_block(code, block_object_table, objects_in_table)
  maddr code;
  Object *block_object_table[];
  int objects_in_table;
{
	/* gc the block objects */
  gc_globals(block_object_table, objects_in_table);

  if (block_object_table) free((char *)block_object_table);

  free((char *)code);
}

/* ******************************************************************** */
/* ****************** Outside access to Mutt Machine ****************** */
/* ******************************************************************** */

static jmp_buf env;
static int pgm_level = 0;   /* keep track of recursion level for setjmp */

    /* Is a pgm running?
     * Returns:
     *   FALSE: no pgm running.
     *   n :  n pgms are running (interrupts, (load) can cause more than one
     *	      pgm to be running at the same time.
     */
MMpgm_running() { return pgm_level; }

    /* Execute Mutt code:  This is the front end to the Mutt Machine.  This
     *   is the ONLY routine that calls MM() other than MM itself (exetern()
     *   is considered part of MM).
     * If a child (sub pgm, etc) dies, the parent/everybody dies.
     * Input:
     *   entrypt : address of Mutt code to be executed.
     * Returns:
     *   TRUE : pgm ran to completation
     *   FALSE: pgm aborted
     * Notes:
     *   Caller MUST have set up a stack frame!
     *   Hooks or interrupts can cause this code to recurse.
     *   I am careful to save MMask_pgm from reentrent or recursive code
     *     that is run while another pgm is running.
     *   A long jump buffer is set up so we can return here if the code
     *     aborts (by calling MMabort_pgm()).
     *   This routine is not called much (only by the application to run a
     *     program) so I don't have to worry (much) about speed.
     *   When MM() returns, a complete program has run (since MM doesn't
     *     call this).
     *   After a program has finished running, need to gc, reset and
     *     generally clean up.  If recursing, only gc the local objects -
     *     can't reset because that would mess up the stack for the other
     *     running program.  When no programs are running, can reset
     *     everything.
     */
static int execode(entrypt) maddr entrypt;
{
  int old_ask_pgm = MMask_pgm;

  MMask_pgm = TRUE;
  pgm_level++;
  if (pgm_level != 1 || setjmp(env) == 0)
  {
    MM(entrypt);		/* might longjmp() */
	/* pgm ran to completion */
    pgm_level--;
    MMask_pgm = old_ask_pgm;
    pop_stkframe();

    if (pgm_level == 0) reset_MM(FALSE);
    else OMgc_pool(local_object_pool, 0);

    return TRUE;
  }

      /* Pgm aborted. MMabort_pgm() resets stacks, MMask_pgm, objects, etc */
  pgm_level = 0;
  return FALSE;
}

	/* Heres where the outside world fires off a Mutt pgm.
	 * Returns FALSE if pgm aborts.
	 * Note:
	 *  If MMrun_pgm() gets called recursively and then aborts,
	 *    everything is aborted.
	 */
MMrun_pgm(n)	/* run the nth Mutt pgm */
{
  MMStkFrame mark;

  setframe(&mark, asp(), vsptr);
  return execode(MMpgm_addr(n));
}

	/* Next rouines allow external things to set up a stack frame,
	 *   push args, etc and then run a pgm with that frame.
	 * Sequence: open frame, push args, run with args or (close frame
	 *   and load).
	 * Note: guard your stack frame against recursion.
	 */
void MMopen_frame(mark) MMStkFrame *mark;
	{ mark->startframe = asp(); mark->vsptr = vsptr; }

void MMpush_arg(RV) MMDatum *RV;
{
  if (RV->type == STRING) RV->val.str = pushstr(RV->val.str);
  vpush(RV);
}

void MMclose_frame(mark) MMStkFrame *mark;
	{ setframe(mark,mark->startframe,mark->vsptr); }

	/* run the nth Mutt pgm with args */
MMrun_pgm_with_args(n,mark) MMStkFrame *mark;
{
  MMclose_frame(mark);
  return execode(MMpgm_addr(n));
}

    /* Load a code file (block) and run the MAIN code.
     * Input:
     *   fname:  Name of the file that contains the code.  The application
     *     knows how to interpret this.
     *   complain:  TRUE:  Complain if can't open fname.
     * Output:
     *   TRUE:  Block loaded and MAIN code ran to completion.
     *   FALSE: Block didn't load, MAIN didn't run or something else failed.
     *		A message was probably issued.
     * Notes
     *   Maintaining a stack frame here is sometimes redundant.  If called
     *     from a pgm, the callee already has a stack frame.  When called
     *     called directly from an application, it may or may not be as a
     *     result of a running pgm.  If so, got a stack frame.  If not, a
     *     call to init_stacks() after would that last pgm is run would take
     *     care of everything.
     *   Since MMload_code() changes the global var pointers, need to set up
     *     a stack frame before that call.
     */
MMload(fname,complain) char *fname;
{
  maddr entrypt;
  MMStkFrame mark;

  setframe(&mark,asp(),vsptr);
  if ((entrypt = MMload_code(fname,complain)) != NULL) return execode(entrypt);

  pop_stkframe();	/* didn't load code: reset global var pointers */

  return FALSE;
}

    /* Initialize the Mutt Machine.  This is called by the application ONCE
     *   so MM can set things up.
     * Call this AFTER everything else in your application has been
     *   initialized (this might call back into the application).
     * Returns:
     *   TRUE:  everything went as expected.
     *   FALSE:  Mutt Machine can't be initialized, don't use it!
     */
int MMinitialize()
{
  init_stacks();

  if (!(local_object_pool  = OMcreate_object_pool(local_gc_marker))	||
      !(global_object_pool = OMcreate_object_pool((pfi)NULL))		||
      !(tmp_object_pool    = OMcreate_object_pool((pfi)NULL)))
	return FALSE;

/* ??? malloc result? */

  return TRUE;
}

/* ******************************************************************** */
/* ****************** Error handling ********************************** */
/* ******************************************************************** */

	/* dump levels:
	 *  0 - No nuthin
	 *  n - Implementer defined
	 */
void MMabort_pgm(dump_level)
{
/*  if (dump_level) MMtrace_back(dump_level);	/* ??? */
  reset_MM(TRUE);
  longjmp(env,1);
}