home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / me34src.zip / me3 / mc / mm.c < prev    next >
C/C++ Source or Header  |  1995-01-14  |  46KB  |  1,496 lines
  1. /*
  2.  * mm.c : the Mutt Machine
  3.  *  Craig Durland 6/87
  4.  *    Added dstrings, more comments    3/91
  5.  *    lists, ojbect manager        mid '91
  6.  *  See mm2.doc for lots of documentation.
  7.  */
  8.  
  9. /* Copyright 1990 - 1993 Craig Durland
  10.  *   Distributed under the terms of the GNU General Public License.
  11.  *   Distributed "as is", without warranties of any kind, but comments,
  12.  *     suggestions and bug reports are welcome.
  13.  */
  14.  
  15. static char what[] = "@(#)MM2 (Mutt Machine II) v2.3 6/6/93";
  16.  
  17. #include <stdio.h>
  18. #include <setjmp.h>
  19. #include <os.h>
  20. #include <const.h>
  21. #include "opcode.h"
  22. #include "mm.h"
  23. #include "oman.h"
  24.  
  25. extern char *calloc(), *malloc(), *strcpy(), *strcat(), *l_to_a();
  26. extern long atol();
  27.  
  28. char *MMvtoa();
  29.  
  30. typedef struct
  31. {
  32.    uint8 type;
  33.    union { uint16 t; char *name; maddr addr; int32 laddr; } token;
  34.    int abase, vsptr;    /* part of the stack frame */
  35. } ositem;
  36.  
  37. #define OPL_ADDRESS 0xC5    /* !!! long address */
  38.  
  39. MMDatum RV, TV;            /* Mutt Machine registers */
  40.  
  41. /* ******************************************************************** */
  42. /* ************************ Object Management ************************* */
  43. /* ******************************************************************** */
  44.  
  45. static int is_object();
  46.  
  47. #define IS_STRING(type) (((type) == STRING) || ((type) == OSTRING))
  48. #define MAKE_STRING(rv)    \
  49.   (((rv).type == OSTRING) ? OBJSTRING((rv).val.object) : (rv).val.str)
  50.  
  51.  
  52. extern Object *OMcreate_object(), *OMextract_elements(),
  53.           *OMdup_object(), *OMnth_element();
  54. extern ObjectPool *OMcreate_object_pool();
  55.  
  56.     /* ********** local objects **************** */
  57. #define MAX_LOCAL_OBJECTS ASTACKSIZ
  58.  
  59. static ObjectPool *local_object_pool, *tmp_object_pool;
  60.  
  61. static Object *local_object_table[MAX_LOCAL_OBJECTS];
  62. static int lobj_max = 0, lobj_start = 0;
  63.  
  64. static void lobj_push(object) Object *object;
  65. {
  66.   if (lobj_max == MAX_LOCAL_OBJECTS) MMbitch("Object table overflow");
  67.   local_object_table[lobj_max++] = object;
  68. }
  69.  
  70. static Object *get_lobj(n) int n;
  71.   { return local_object_table[lobj_start + n]; }
  72.  
  73.  
  74.     /* Routine to gc local objects.
  75.      * All live local objects are marked.
  76.      * If RV is an object and is in the local pool, need to mark it also.
  77.      * Notes:
  78.      *   It would be easier to mark dead objects (don't have to mess with
  79.      *     RV) but I don't know where the dead objects are in
  80.      *     local_object_table[] - lobj_start and lobj_max reflect the
  81.      *     current live range.
  82.      *   Worrying about RV being in the local pool stinks - the only time it
  83.      *     will matter is if a program is returning a (local) object when we
  84.      *     gc.  Then only time this regularly happens is when all programs
  85.      *     are done and then it only matters if the application wants the
  86.      *     object.  Most of the time a OSTRING is sitting in RV that nobody
  87.      *     cares about.  Unfortunately, I don't know of a easy/fast way to
  88.      *     get around these problems.
  89.      */
  90. static int local_gc_marker()
  91. {
  92.   int j;
  93.  
  94.   if (is_object(RV.type) && OMin_pool(local_object_pool, RV.val.object))
  95.     OMgc_mark_object(RV.val.object);
  96.  
  97.   for (j = lobj_max; j--; ) OMgc_mark_object(local_object_table[j]);
  98.  
  99.   return 1;        /* live objects are marked */
  100. }
  101.  
  102.     /* ********** global objects **************** */
  103.  
  104. static ObjectPool *global_object_pool;
  105.  
  106. Object **MMglobal_object_table;        /* Object *MMglobal_object_table[]; */
  107.  
  108. static void gobj_push(object, n) Object *object;
  109. {
  110.   MMglobal_object_table[n] = object;
  111. }
  112.  
  113.     /* Routine to gc global objects.
  114.      * I only gc a block when the block is freed (since global objects live
  115.      *   as long as the block does.  When the block is freed, I need to free
  116.      *   up all objects in the block.
  117.      * Input:
  118.      *   object_table:  Pointer to the block (being freed) object table.
  119.      *   num_objects:  Number of object in object_table.
  120.      * Notes:
  121.      *   Call this when a block is freed.
  122.      *   All global objects are in the same object pool.
  123.      *   Only gc when a block is freed because thats the only time there
  124.      *     will be garbage in this pool.  So don't GC when run out of memory
  125.      *     or when somebody gc's the world.
  126.      *   I mark all dead objects (the ones in the block object table)
  127.      *     because thats easy.
  128.      */
  129. static void gc_globals(object_table, num_objects) Object *object_table[];
  130. {
  131.   int j;
  132.  
  133.   if (num_objects == 0) return;        /* avoid unnecessary work */
  134.  
  135.   for (j = num_objects; j--; ) OMgc_mark_object(object_table[j]);
  136.  
  137.   OMgc_pool(global_object_pool, 2);    /* dead objects are marked */
  138. }
  139.  
  140.     /* ****************** Object Utilities ******************* */
  141.     /* Is type an object type?
  142.      * Notes:
  143.      *   If type is STRING and points into a OSTRING, we are screwed.  I
  144.      *     don't think I do this however.
  145.      */
  146. static int is_object(type) int type;
  147. {
  148.   return (type == OSTRING || type == LIST);
  149. }
  150.  
  151.     /* !!!
  152.      * Notes:
  153.      *   I call OMset_object() alot and don't check for errors.  This is bad
  154.      *     but I'm real tired of error checking right now.  Besides, only a
  155.      *     few cases will cause problems and if there are errors, they will
  156.      *     be out of memory problems - in which case not much is working
  157.      *     anyway (probably).  And these are "soft" failures - the data
  158.      *     types don't change and the data is valid, just wrong.  Could make
  159.      *     for some fun Mutt debugging.
  160.      *     Yes, I plan to fix it one of these years.  Or I will avoid it by
  161.      *       rewriting this stuff yet again.
  162.      * !!!
  163.      */
  164.  
  165.     /* !!! no workie much */
  166. static Object *convert_to_object(pool, val) ObjectPool *pool; MMDatum *val;
  167. {
  168.   int type;
  169.   Object *object;
  170.  
  171.   type = val->type;
  172.   if (is_object(type)) return val->val.object;
  173.  
  174.   if (type == STRING) type = OSTRING;
  175.   if (!(object = OMcreate_object(pool, type, 0))) return NULL;
  176.   switch (type)
  177.   {
  178.     case NUMBER:  OMset_object(object, type, (long int)val->val.num); break;
  179.     case OSTRING: OMset_object(object, type,           val->val.str); break;
  180.     default: return NULL;
  181.   }
  182.   return object;
  183. }
  184.  
  185.     /* !!! no workie much */
  186. void MMconvert_to_datum(object, val) Object *object; MMDatum *val;
  187. {
  188.   int type;
  189.  
  190.   type = object->type;
  191.   switch (type)
  192.   {
  193.     case NUMBER:  val->val.num = OBJNUMBER(object); break;
  194.     case LIST:
  195.     case OSTRING:
  196.     val->val.object = object; break;
  197.   }
  198.   val->type = type;
  199. }
  200.  
  201. /* ******************************************************************** */
  202. /* ************************* Stack Management ************************* */
  203. /* ******************************************************************** */
  204.  
  205. extern int MMask_pgm;
  206.  
  207. int MMcurrent_block = -1;  /* to force MMset_block() to sync the first time */
  208.  
  209. static MMStkFrame *prev_stkframe;
  210. static int vsptr, asptr, osptr, abase, vbase, numargs;
  211.  
  212. static ositem opstack[OSTACKSIZ];        /* opcode stack */
  213. static MMDatum argstack[ASTACKSIZ];        /* arg stack */
  214. static uint8  varstack[VSTACKSIZ];        /* flotsam, vars and jetsam */
  215.  
  216. static maddr pc;            /* MM program counter */
  217.  
  218. uint8 *MMglobal_vars;        /* start of global variables */
  219.  
  220. #define asp() asptr
  221. #define aspset(n) asptr = (n)
  222.  
  223.     /* Initialize the Mutt Machine.  Set all state variables, stacks, etc to
  224.      *   their initial state.
  225.      * Notes
  226.      *   This MUST be called before the first pgm is run.
  227.      *   Call when a pgm aborts or halts.
  228.      *   Don't need to call this a pgm is done because poping the stack last
  229.      *     stack frame will restore things to this state.
  230.      */
  231. static void init_stacks()
  232. {
  233.   asptr = osptr = vsptr = abase = vbase = numargs = 0;
  234.   prev_stkframe = NULL;
  235.  
  236.   lobj_max = lobj_start = 0;
  237.  
  238. #if 0    /* !!!??? */
  239.   MMglobal_vars = NULL;
  240.   MMglobal_object_table = NULL;
  241.   MMset_block(0);    /* I don't think I care */
  242. #endif
  243. #if 0
  244. /* can't do because MMinit calls this before add_block is ever called */
  245.     /* Force the app to sync MMcurrent_block just in case they are out
  246.      *   of sync.
  247.      */
  248.   MMcurrent_block = -1;
  249.   MMset_block(0);
  250. #endif
  251. }
  252.  
  253.     /* Save the current stack frame in mark & set up new a frame. 
  254.      * Notes:
  255.      *   Only need to save the block local data (MMglobal_vars and
  256.      *     MMglobal_object_table) when a function call will switch blocks
  257.      *     (such as calling an external pgm (eg via OPNAME or FADDR)), in
  258.      *     other cases, they don't change.
  259.      */
  260. static void setframe(mark,startframe,flotsam) register MMStkFrame *mark;
  261. {
  262.   mark->abase = abase; mark->startframe = abase = startframe;
  263.   mark->vbase = vbase; mark->vsptr = flotsam;
  264.   mark->numargs = numargs;
  265.   mark->pc = pc;
  266.   mark->prev_stkframe = prev_stkframe;
  267.  
  268.   prev_stkframe = mark;
  269.   vbase = vsptr;    /* set vbase after flotsam */
  270.   numargs = asp() -abase;
  271.  
  272. /* ???  Instead of putting gvars and global object table in stackframe,
  273.  * why not put in a block pointer and dig it out of there on reset?
  274.  */
  275. #define CBLOCK 1
  276. #if CBLOCK
  277.   mark->block_id = MMcurrent_block;
  278. #else
  279.   mark->gvars = MMglobal_vars;
  280.   mark->global_object_table = MMglobal_object_table;
  281. #endif
  282.  
  283.   mark->lobj_max = lobj_max; mark->lobj_start = lobj_start;
  284.   lobj_start = lobj_max;
  285. }
  286.  
  287. static void resetframe(mark)        /* reset a stack frame */
  288.   register MMStkFrame *mark;
  289. {
  290.   aspset(mark->startframe);
  291.   abase = mark->abase; vbase = mark->vbase;
  292.   numargs = mark->numargs;
  293.   pc = mark->pc; vsptr = mark->vsptr;
  294.  
  295. #if CBLOCK
  296.   MMset_block(mark->block_id);
  297. #else
  298.   MMglobal_vars = mark->gvars;
  299.   MMglobal_object_table = mark->global_object_table;
  300. #endif
  301.  
  302.   lobj_max = mark->lobj_max; lobj_start = mark->lobj_start;
  303. }
  304.  
  305. static void pop_stkframe()
  306. {
  307.   resetframe(prev_stkframe);
  308.   prev_stkframe = prev_stkframe->prev_stkframe;
  309. }
  310.  
  311.    /* Don't use this if you turn around and call MM().
  312.     * Set MMask_pgm to TRUE after you do the ask.
  313.     * This is ment for self contained opcodes.
  314.     */
  315. void MMset_ask_frame()
  316. {
  317.   resetframe(prev_stkframe);
  318.   MMask_pgm = (MMask_pgm && numargs);
  319. }
  320.  
  321. void MMreset_ask_frame()
  322. {
  323.   prev_stkframe->numargs = numargs;
  324.   prev_stkframe->abase = abase;
  325.   MMask_pgm = TRUE;        /* reset (ask-user) */
  326. }
  327.  
  328. MMgonna_ask_pgm()
  329. {
  330.   return (MMask_pgm && prev_stkframe->numargs);
  331. }
  332.  
  333. static void vpush(val) MMDatum *val;
  334. {
  335.   if (asptr == ASTACKSIZ) MMbitch("arg stack overflow");
  336.   argstack[asptr++] = *val;
  337. }
  338.  
  339. static void vpop(val) MMDatum *val; { *val = argstack[--asptr]; }
  340.  
  341.     /* Pull the nth arg out of the stack frame.
  342.      * This routine for people writing Mutt extensions.  It is used to get
  343.      *   parameters off the stack.  For example, if you are writing the C
  344.      *   code for "foo" and it is called like so:  (foo 123), then when your
  345.      *   foo code is called, you can MMpull_nth_arg(&RV,0) and RV will be a
  346.      *   number with value 123.
  347.      * See also:  MMnext_arg().
  348.      * Notes:
  349.      *   Don't have to worry about garbage collection because I'm just
  350.      *     copying pointers - the objects remain in the local stack and will
  351.      *     not be collected.
  352.      * Input:
  353.      *   val:  Pointer to a var (MMDatum).  Arg will be stashed there.
  354.      *     Usually &RV.
  355.      *   n:  The arg you want to pull.  0 is the first and numargs is 1+
  356.      *     the last (not that it helps you - you have to use (nargs) or
  357.      *     MMpull_nth_arg() until it returns false.
  358.      * Output:
  359.      *   val:  MMDatum is filled in with pointers to nth stack arg.  If it
  360.      *     is an object string, it points to the contents of the string.
  361.      * Returns:
  362.      *   TRUE:  Got to the arg
  363.      *   FALSE:  n if out range (less than 0 or greater than the number of
  364.      *         args)
  365.      */
  366. MMpull_nth_arg(val,n) MMDatum *val; int n;    /* pull the nth arg */
  367. {
  368.   if (n >= numargs || n < 0) return FALSE;
  369.   *val = argstack[abase+n];
  370.  
  371.   if (val->type == OSTRING)
  372.   {
  373.     val->type = STRING;
  374.     val->val.str = OBJSTRING(val->val.object);
  375.   }
  376.  
  377.   return TRUE;
  378. }
  379.  
  380.     /* Same as MMpull_nth_arg() 'cept no object conversion.  Ment to for
  381.      *   internal consumption.
  382.      */
  383. static int apulln(val,n) MMDatum *val; int n;    /* pull the nth arg */
  384. {
  385.   if (n >= numargs || n < 0) return FALSE;
  386.   *val = argstack[abase+n];
  387.  
  388.   return TRUE;
  389. }
  390.  
  391.     /* Get the next arg in the stack frame, convert it to a string and store
  392.      *   it in a buffer.
  393.      * Ment for stuff that wants a bunch of ascii info from something and
  394.      *   does the conversions itself (like (ask)).  Use this routine when
  395.      *   writing a routine that can get info from either a user or Mutt pgm.
  396.      * Input:
  397.      *   buf: Pointer to a area to store the ascii form of the var in.
  398.      * Returns:
  399.      *   FALSE: No more args
  400.      *   TRUE:  all OK
  401.      * Munges:
  402.      *   TV
  403.      * WARNING!
  404.      *   Make sure this does NOT setjmp()!
  405.      */
  406. MMnext_arg(buf) char *buf;    /* ask a pgm instead of user */
  407. {
  408.   if (!MMpull_nth_arg(&TV,0)) { MMmoan("not that many args"); return FALSE; }
  409.   strcpy(buf,MMvtoa(&TV));
  410.   abase++; numargs--;
  411.  
  412.   return TRUE;
  413. }
  414.  
  415. static void set_MMvar(ptr,type) uint8 *ptr;    /* var = RV */
  416. {
  417.   switch (type)
  418.   {
  419.     case INT8:
  420.     case BOOLEAN: PUT_UINT8(ptr,RV.val.num);        break;
  421.     case INT16:   PUT_INT16(ptr,RV.val.num);        break;
  422.     case INT32:   PUT_INT32(ptr,RV.val.num);        break;
  423.     case BLOB:    PUT_INT32(ptr,(int32)RV.val.blob);    break;
  424.   }
  425. }
  426.  
  427. static void get_MMvar(ptr,type) uint8 *ptr;    /* RV = var */
  428. {
  429.   RV.type = type;
  430.   switch (type)
  431.   {
  432.     case INT8:    RV.type = NUMBER; RV.val.num = GET_UINT8(ptr); break;
  433.     case INT16:   RV.type = NUMBER; RV.val.num = GET_INT16(ptr); break;
  434.     case INT32:   RV.type = NUMBER; RV.val.num = GET_INT32(ptr); break;
  435.     case BOOLEAN: RV.val.num = GET_UINT8(ptr);             break;
  436.     case BLOB:    RV.val.blob = (uint8 *)GET_INT32(ptr);     break;
  437.   }
  438. }
  439.  
  440. static uint8 *lalloc(n)        /* alloc n bytes on varstack, 0 == noop */
  441. {
  442.   uint8 *ptr = &varstack[vsptr];
  443.  
  444.   vsptr += n;
  445.   if (vsptr > VSTACKSIZ) MMbitch("var stack overflow");
  446.   return ptr;
  447. }
  448.  
  449. static char *pushstr(str) char *str;
  450. { return strcpy(lalloc(strlen(str) + 1),str); }
  451.  
  452.     /* Check to see a string is out of the "live" stack frames.  This can
  453.      *   happen if a string is pushstr()'d, a function called and that
  454.      *   function returns the string - the string is in a dead frame and can
  455.      *   be overwritten.
  456.      * Since the string is already in varstack, we know it will fit.
  457.      * This is only called from PUSHRV and basically replaced a call to
  458.      *   pushstr().  Can't use pushstr() because strcpy() might not handle
  459.      *   overlapping strings.
  460.      * This routine is the result of one of those pain in the butt bugs that
  461.      *   took me a long time to figure out.  Oh well, it is not called much.
  462.      */
  463. static int vble(str) uint8 *str;
  464. {
  465.   if ((varstack + vsptr) <= str && str < (varstack + VSTACKSIZ))
  466.   {
  467.     char *ptr;
  468.  
  469.     RV.val.str = ptr = (char *)lalloc(strlen(str) + 1);
  470.     while (*ptr++ = *str++) ;    /* copy upto and including the '\0' */
  471.   }
  472.   return FALSE;
  473. }
  474.  
  475. static void opush(op) ositem *op;
  476. {
  477.   if (osptr == OSTACKSIZ) MMbitch("opstack overflow");
  478.   opstack[osptr++] = *op;
  479. }
  480.  
  481. static void opop(op) ositem *op; { *op = opstack[--osptr]; }
  482.  
  483. /* ******************************************************************** */
  484. /* ********************** Handle Imbedded Types *********************** */
  485. /* ******************************************************************** */
  486.  
  487. maddr pcat() { return pc; }
  488.  
  489. static maddr addr()    /* grab relative addr at pc, advance the pc */
  490. {
  491.   maddr a = pc +GET_INT16(pc + 1);
  492.   pc += sizeof(int16);
  493.   return a;
  494. }
  495.  
  496. static int num8()    /* grab a uint8 at the pc, advance the pc */
  497. {
  498.   int n = GET_UINT8(pc + 1);    /* assumes no sign extension ie 0xFF => 255 */
  499.   pc += sizeof(uint8);
  500.   return n;
  501. }
  502.  
  503. static int num16()    /* grab a int16 at the pc, advance the pc */
  504. {
  505.   int n = GET_INT16(pc + 1);
  506.   pc += sizeof(int16);
  507.   return n;
  508. }
  509.  
  510. static int32 num32()    /* grab a int32 at the pc, advance the pc */
  511. {
  512.   int32 n = GET_INT32(pc + 1);
  513.   pc += sizeof(int32);
  514.   return n;
  515. }
  516.  
  517. #define STR() (char *)(MMglobal_vars - num16())
  518.  
  519. /* ******************************************************************** */
  520. /* ************************* the Mutt Machine ************************* */
  521. /* ******************************************************************** */
  522.  
  523. extern maddr MMblock_code();    /* in the application */
  524.  
  525. void MMabort_pgm();
  526.  
  527. static void exetern(), dotok(), convert_to();
  528.  
  529. static int n, n1;
  530. static uint8 *blob;
  531. static ositem op;
  532.  
  533. char result[RSIZ];    /* A stash to hold STRINGs */
  534.    /* MMask_pgm is initially FALSE so when pgms aren't running the outside
  535.     *   world won't get confused.
  536.     */
  537. int MMask_pgm = FALSE;
  538.  
  539. #define opcode() *pc
  540. #define incpc()   pc++
  541.  
  542.     /* Reset the Mutt Machine.
  543.      * This is called when no Mutt programs are running ie when the last
  544.      *   program has finished running.  It resets the stacks, garbage
  545.      *   collects MM and the application and general clean up to make ready
  546.      *   for the next program to run.
  547.      * Notes:
  548.      *   If a program stops and leaves a (local) object in RV, it is not
  549.      *     GCed.  This is because an application may want to see the result
  550.      *     of running a program.  ??? I'm not sure this is a good idea.  The
  551.      *     object should be GCed when the next program runs and only cause a
  552.      *     problem with big objects.
  553.      * Input:
  554.      *   aborting:  TRUE if this is being called because MM is aborting.
  555.      */
  556. static void reset_MM(aborting)
  557. {
  558.   if (aborting)
  559.   {
  560.     init_stacks();
  561.     RV.type = NUMBER;    /* so garbage collecter won't think this is a object */
  562.   }
  563.   MMgc_external_objects();
  564.   OMgc_pool(tmp_object_pool, 1);    /* live (ie none) objects are marked */
  565.   OMgc_pool(local_object_pool, 0);  /* OMgc_the_world(); */
  566.   MMask_pgm = FALSE;
  567. }
  568.  
  569.     /* The Mutt Machine main loop.
  570.      * Notes
  571.      *   To avoid having to maintain a stack of stack frames, I use
  572.      *     recursion.  This means that I need to save a stack frame (eg for
  573.      *     function calls), I call myself and let C save it for me.
  574.      * Input:
  575.      *   startaddr:  Address of the code to run.  Must have set up a stack
  576.      *     frame (ie all state vars are set to "proper" values).
  577.      * Result:
  578.      *   Side effects up the wazoo.
  579.      */
  580. static void MM(startaddr) maddr startaddr;
  581. {
  582.   MMStkFrame mark;
  583.  
  584.   pc = startaddr;
  585.   while(TRUE)
  586.   {
  587.     switch(opcode())
  588.     {
  589.       case HALT: MMabort_pgm(0);
  590.       case DONE: goto done;
  591.  
  592.       case ASKUSER: MMask_pgm = FALSE; RV.type = VOID; break;
  593.  
  594.       case RVBOOL:  RV.type = BOOLEAN; RV.val.num = num8();  break;
  595.       case RVNUM8:  RV.type = NUMBER;  RV.val.num = num8();  break;
  596.       case RVNUM16: RV.type = NUMBER;  RV.val.num = num16(); break;
  597.       case RVNUM32: RV.type = NUMBER;  RV.val.num = num32(); break;
  598.       case RVSTR:   RV.type = STRING;  RV.val.str = STR();   break;
  599.       case RVVOID:  RV.type = VOID; break;
  600.  
  601.       case ADD: vpop(&TV); RV.val.num += TV.val.num;          break;
  602.       case SUB: vpop(&TV); RV.val.num  = TV.val.num - RV.val.num; break;
  603.       case MUL: vpop(&TV); RV.val.num *= TV.val.num;          break;
  604. /* !!!??? divide by zero exceptable???? core dump */
  605.       case DIV: vpop(&TV); RV.val.num  = TV.val.num / RV.val.num; break;
  606.  
  607.       case CMP:
  608.     vpop(&TV);
  609.     if (IS_STRING(RV.type))
  610.       n = (0 == strcmp(MAKE_STRING(RV), MAKE_STRING(TV)));
  611.     else n = (RV.val.num == TV.val.num);
  612.  
  613.     RV.type = BOOLEAN; RV.val.num = n;
  614.     break;
  615.       case NOT: RV.val.num = !RV.val.num; break;
  616.       case LT:                /* (< x y) => (vpop < RV) */
  617.     vpop(&TV); RV.val.num = (TV.val.num < RV.val.num);  RV.type = BOOLEAN;
  618.     break;
  619.       case LTE:                /* (<= x y) => (vpop <= RV) */
  620.     vpop(&TV); RV.val.num = (TV.val.num <= RV.val.num); RV.type = BOOLEAN;
  621.     break;
  622.  
  623.       case JMP:           pc = addr(); continue;
  624.       case JMPTRUE:
  625.         if (RV.val.num)  { pc = addr(); continue; }
  626.     addr();
  627.     break;
  628.       case JMPFALSE:
  629.         if (!RV.val.num) { pc = addr(); continue; }
  630.     addr();
  631.     break;
  632.  
  633.       case ARG:
  634.     if (!apulln(&RV,(int)RV.val.num))
  635.         MMbitch("(arg n): Not that many args.");
  636.     break;
  637.       case NARGS: RV.type = NUMBER; RV.val.num = numargs; break;
  638.       case PUSHARGS:
  639.     n = RV.val.num;
  640.     while (apulln(&RV,n++)) vpush(&RV);
  641.     break;
  642.  
  643.       case PUSHRV:
  644.     if (RV.type == STRING && (RV.val.str == result || vble(RV.val.str)))
  645.       RV.val.str = pushstr(RV.val.str);
  646.     else
  647.       if (RV.type & OPMASK)        /* setup a fcn call */
  648.       {
  649.         switch (op.type = RV.type)
  650.         {
  651.           case OPTOKEN:
  652.           case OPXTOKEN:  op.token.t = RV.val.num; break;
  653.           case OPADDRESS:
  654.             op.token.laddr = RV.val.num;
  655.         op.type = OPL_ADDRESS;
  656.         break;
  657.           case OPNAME:
  658.         op.token.name = RV.val.str;  /* FADDR ensures not in result */
  659.         }
  660.         goto setop;
  661.       }
  662.       /* else just shove it */
  663.       case SHOVERV: vpush(&RV); break;
  664.       case DUP: vpop(&TV); vpush(&TV); vpush(&TV); break;
  665.       case POP: vpop(&TV); break;    
  666.  
  667.       case PUSHTOKEN:
  668.     op.type = OPTOKEN; op.token.t = num16();
  669.   setop:
  670.     op.abase = asp(); op.vsptr = vsptr; opush(&op);
  671.     break;
  672.       case PUSHXT:   op.type = OPXTOKEN;  op.token.t    = num16(); goto setop;
  673.       case PUSHNAME: op.type = OPNAME;    op.token.name = STR();   goto setop;
  674.       case PUSHADDR: op.type = OPADDRESS; op.token.addr = addr();  goto setop;
  675.       case FADDR:
  676.         switch(n = num8())    /* type: one of the OPxxxx code types */
  677.     {
  678.       case OPTOKEN:
  679.       case OPXTOKEN:  RV.val.num = num16(); break;
  680.       case OPADDRESS:
  681. #if CBLOCK
  682. #else
  683. find_block();    /*  */
  684. #endif
  685.         RV.val.num = 
  686.         (((int32)MMcurrent_block << 24) | (addr() - MMblock_code()));
  687.         break;
  688.       case OPNAME:        /* RV is STRING or OSTRING */
  689.         if (RV.type == OSTRING)     /* protect against GC */
  690.           RV.val.str = pushstr(OBJSTRING(RV.val.object));
  691.         else    /* STRING: protect against RV getting munged */
  692.           if (RV.val.str == result) RV.val.str = pushstr(RV.val.str);
  693.         break;
  694.     }
  695.     RV.type = n;
  696.     break;
  697.  
  698.       case DOOP:
  699.     opop(&op); setframe(&mark,op.abase,op.vsptr);
  700.     switch(op.type)
  701.     {
  702.       case OPL_ADDRESS:
  703.         MMset_block((op.token.laddr >> 24) & 0xff);
  704.         MM(MMblock_code() + (op.token.laddr & 0xffffff));
  705.         break;
  706.       case OPADDRESS: MM(op.token.addr); break;
  707.       case OPTOKEN:   dotok(op.token.t); break;
  708.       case OPNAME:    RV.type = VOID; exetern(op.token.name); break;
  709.       case OPXTOKEN:  RV.type = VOID; MMxtoken(op.token.t); break;
  710.     }
  711.     pop_stkframe();
  712.     break;
  713.  
  714.       case TYPECHECK:
  715.     n = num8();
  716.     if (RV.type != n && !(n == STRING && RV.type == OSTRING))
  717.         MMbitch("Type mismatch");
  718.     break;
  719.  
  720.       case LALLOC: lalloc(num16()); break;
  721.       case GETLVAR:                 /* (get-local-var type offset) */
  722.         n = num8();    /* type */
  723.     n1 = num16();    /* offset */
  724.     if (n == STRING)    /* compiler should say OSTRING */
  725.     {
  726.       RV.type = OSTRING;
  727.       RV.val.object = get_lobj(n1);
  728.     }
  729.     else
  730.       if (n == LIST)
  731.       {
  732.         RV.type = LIST;
  733.         RV.val.object = get_lobj(n1);
  734.       }
  735.       else get_MMvar(&varstack[vbase + n1],n);
  736.     break;
  737.       case GETGVAR:                /* (get-global-var type offset) */
  738.         n = num8();    /* type */
  739.     n1 = num16();    /* offset */
  740.     if (n == STRING)    /* compiler should say OSTRING */
  741.     {
  742.       RV.type = OSTRING;
  743.       RV.val.object = MMglobal_object_table[n1];
  744.     }
  745.     else
  746.       if (n == LIST)
  747.       {
  748.         RV.type = LIST;
  749.         RV.val.object = MMglobal_object_table[n1];
  750.       }
  751.       else  get_MMvar(MMglobal_vars + n1, n);
  752.     break;
  753.       case SETLVAR:                 /* (set-local-var type offset) */
  754.         n = num8();    /* type */
  755.     n1 = num16();    /* offset */ 
  756.     switch(n)
  757.     {
  758.       case STRING:            /* var is a string object */
  759.         if (RV.type == STRING)        /* string constant */
  760.           OMset_object(get_lobj(n1), OSTRING, RV.val.str);
  761.         else                /* string object */
  762.           OMset_object(get_lobj(n1), OSTRING, OBJSTRING(RV.val.object));
  763.         break;
  764.       case LIST:            /* var is a list object */
  765.         OMset_object(get_lobj(n1), LIST, RV.val.object);
  766.         break;
  767.       default:        /* every other var type */
  768.         set_MMvar(&varstack[vbase + n1],n);
  769.         break;
  770.     }
  771.     break;
  772.       case SETGVAR:                /* (set-global-var type offset) */
  773.         n = num8();    /* type */
  774.     n1 = num16();    /* offset */ 
  775.     switch(n)
  776.     {
  777.       case STRING:            /* var is a string object */
  778.         if (RV.type == STRING)        /* string constant */
  779.           OMset_object(MMglobal_object_table[n1], OSTRING, RV.val.str);
  780.         else                /* string object */
  781.           OMset_object(MMglobal_object_table[n1],
  782.         OSTRING, OBJSTRING(RV.val.object));
  783.         break;
  784.       case LIST:            /* var is a list object */
  785.         OMset_object(MMglobal_object_table[n1], LIST, RV.val.object);
  786.         break;
  787.       default:        /* every other var type */
  788.         set_MMvar(MMglobal_vars + n1, n);
  789.         break;
  790.     }
  791.     break;
  792.  
  793.       case RVLBASE:
  794.     RV.type = BLOB; RV.val.blob = varstack + vbase + num16(); break;
  795.       case RVGBASE:
  796.         RV.type = BLOB; RV.val.blob = MMglobal_vars + num16();
  797.     break;
  798.       case GETRVAR:                 /* (get-var-relative type) */
  799.     vpop(&TV); get_MMvar(RV.val.blob + TV.val.num,num8()); break;
  800.       case SETRVAR:
  801.     n = num8();        /* type */
  802.     /* !!!  sleeze so I can set object args */
  803.     switch(n)
  804.     {
  805.       case STRING:
  806.         vpop(&TV);
  807.         if (TV.type != OSTRING) MMbitch("set-var-relative:  wanted OSTRING!");
  808.         if (RV.type == STRING)        /* string constant */
  809.           OMset_object(TV.val.object, OSTRING, RV.val.str);
  810.         else                /* string object */
  811.           OMset_object(TV.val.object, OSTRING, OBJSTRING(RV.val.object));
  812.         break;
  813.       case LIST:
  814.         vpop(&TV);
  815.         if (TV.type != LIST) MMbitch("set-var-relative:  wanted list!");
  816.         OMset_object(TV.val.object, LIST, RV.val.object);
  817.         break;
  818.       default:
  819.         vpop(&TV); blob = TV.val.blob; vpop(&TV);
  820.         set_MMvar(blob + TV.val.num, n);
  821.     }
  822.     break;
  823.  
  824.       case CREATE_OBJ:     /* (create-object global/local object-type offset) */
  825.       {
  826.     int global, type, offset;
  827.     Object *object;
  828.  
  829.     global = num8();
  830.     type = num8();
  831.  
  832.     offset = num16();
  833.  
  834.     if (global) object = OMcreate_object(global_object_pool, type, 0);
  835.     else         object = OMcreate_object( local_object_pool, type, 0);
  836.  
  837.     if (!object) MMbitch("No memory to create object!");
  838.     
  839.     if (global) gobj_push(object,offset);
  840.     else lobj_push(object);
  841.  
  842.     break;
  843.       }
  844.       case LEN_OF:                         /* (length-of) */
  845.     switch (RV.type)
  846.     {
  847.       case STRING:
  848.         RV.val.num = (unsigned)strlen(RV.val.str);        break;
  849.       case OSTRING:
  850.       case LIST:
  851.         RV.val.num = (unsigned)OMlength_of(RV.val.object);    break;
  852.       default:    RV.val.num = 0;                break;
  853.     }
  854.     RV.type = NUMBER;
  855.     break;
  856.       case CONVERT_TO:                        /* (convert-to) */
  857.     vpop(&TV);            /* type */
  858.     convert_to((int)TV.val.num, &RV);
  859.     break;
  860.  
  861.       default: MMbitch("Invalid opcode");
  862.     }
  863.     incpc();
  864.   }
  865. done: ;
  866. }
  867.  
  868.     /* Convert a MM type to another MM type.
  869.      * Valid conversions:
  870.      *   NUMBER to:
  871.      *     STRING or OSTRING:  same as (concat).  eg 123 -> "123"
  872.      *     CHARACTER: 0x33 -> "3"
  873.      *     BOOLEAN: 0 -> FALSE and !0 -> TRUE
  874.      *   OSTRING to:
  875.      *     NUMBER:  "123" -> 123
  876.      *     CHARACTER: "3" -> 0x33
  877.      *     BOOLEAN:  "TRUE" -> TRUE    ?????????????????
  878.      *   LIST to:
  879.      *     No valid conversions.
  880.      *   BOOLEAN to:
  881.      *     NUMBER: TRUE -> 1 and FALSE -> 0
  882.      *     STRING: TRUE -> "TRUE"    ??????????????????
  883.      *   BLOB to:
  884.      *     No valid conversions.
  885.      *   VOID to:
  886.      *     No valid conversions.
  887.      *   FCNPTR to:
  888.      *     No valid conversions.
  889.      *   
  890.      * Result
  891.      *   val is converted (in place) to type.
  892.      */
  893. static void convert_to(type, val) MMDatum *val;
  894. {
  895.   int vtype = val->type;
  896.  
  897.   if (type == vtype || (type == OSTRING && IS_STRING(vtype))) return;
  898.  
  899.   switch(vtype)
  900.   {
  901.     default:
  902.      booboo:
  903.       MMbitch("convert-to:  Invalid conversion.");
  904.       break;
  905.     case NUMBER:
  906.       val->type = STRING;
  907.       switch(type)
  908.       {
  909.     default: goto booboo;
  910.     case OSTRING:
  911.       val->val.str = l_to_a((long int)val->val.num);
  912.       break;
  913.     case CHARACTER:
  914.       result[0] = (char)val->val.num; result[1] = '\0';
  915.       val->val.str = result;
  916.       break;
  917.     case BOOLEAN:
  918.       val->val.num = (val->val.num != 0);
  919.       val->type = BOOLEAN;
  920.       break;
  921.       }
  922.       break;
  923.     case STRING:
  924.     case OSTRING:
  925.     {
  926.       char *ptr = MAKE_STRING(*val);
  927.  
  928.       val->type = type;
  929.       switch(type)
  930.       {
  931.     default: goto booboo;
  932.     case NUMBER:
  933.       val->val.num = atol(ptr);
  934.       break;
  935.     case CHARACTER:
  936.       val->type = NUMBER; val->val.num = ptr[0];
  937.       break;
  938.       }
  939.       break;
  940.     }
  941.     case BOOLEAN:
  942.       val->type = type;
  943.       switch(type)
  944.       {
  945.     default: goto booboo;
  946.     case NUMBER:
  947.       val->val.num = (val->val.num != 0);
  948.       break;
  949.       }
  950.       break;
  951.   }
  952. }
  953.  
  954. /* ******************************************************************** */
  955. /* ************************* Internal Tokens ************************** */
  956. /* ******************************************************************** */
  957.  
  958.     /* Internal tokens are like functions:  they need a stack frame with
  959.      *   args in it.  Stack frames make it possible/easier to deal with
  960.      *   functions that take a unknown number of args or type or need to
  961.      *   diddle with callers (ancestor) stack frames.
  962.      * Drawbacks:  takes time (and code) to create the stack frame.
  963.      */
  964.  
  965.  
  966. char *MMvtoa(val) MMDatum *val;            /* MMDatum to ascii */
  967. {
  968.   switch (val->type)
  969.   {
  970.     case BOOLEAN: return val->val.num ? "TRUE" : "FALSE";
  971.     case STRING:  return val->val.str;
  972.     case VOID:    return "VOID";
  973.     case NUMBER:  return l_to_a((long int)val->val.num);
  974.     case OSTRING: return OBJSTRING(val->val.object);
  975.     case LIST:      return "LIST";
  976.   }
  977.   return "BLOB";
  978. }
  979.  
  980. void MMconcat()        /* concatenate a bunch of strings or numbers */
  981. {
  982.   register int n = 0;
  983.  
  984.   *result = '\0';
  985.   while (apulln(&TV,n++)) strcat(result,MMvtoa(&TV));
  986. }
  987.  
  988. static void mm_ask()
  989. {
  990.   char prompt[RSIZ];
  991.  
  992.   if (!MMgonna_ask_pgm()) { MMconcat(); strcpy(prompt,result); }
  993.   MMset_ask_frame();
  994.   if (MMask_pgm)            /* grab arg off the arg stack */
  995.     { if (!MMnext_arg(result)) MMabort_pgm(2); }
  996.   else MMask(prompt,result);        /* ask the user */
  997.   RV.type = STRING; RV.val.str = result;
  998.   MMreset_ask_frame();
  999. }
  1000.  
  1001. static void substr(string, n,z) char *string; int n,z;
  1002. {
  1003.   OMnz_magic(strlen(string), &n,&z);
  1004.   strcpy(result,&string[n]); result[z] = '\0';
  1005.  
  1006.   RV.type = STRING; RV.val.str = result;
  1007. }
  1008.  
  1009.     /* Input:  RV contains object to extract from
  1010.      */
  1011. static void extract_em(n,z, atomize) int n,z, atomize;
  1012. {
  1013.   Object *ptr;
  1014.  
  1015.   switch(RV.type)
  1016.   {
  1017.     default:     MMbitch("extract-element(s):  invalid type!");
  1018.     case STRING: substr(RV.val.str, n,z); break;
  1019.     case OSTRING:
  1020.     case LIST:
  1021.       if (atomize)
  1022.       {
  1023.     if (ptr = OMnth_element(local_object_pool, RV.val.object, n))
  1024.         MMconvert_to_datum(ptr, &RV);
  1025.       }
  1026.       else
  1027.     if (ptr = OMextract_elements(local_object_pool, RV.val.object, n,z))
  1028.         RV.val.object = ptr;
  1029.  
  1030.       if (!ptr) MMbitch("extract-element(s):  Out of memory!");
  1031.   }
  1032. }
  1033.  
  1034.     /* (insert-object object n new-object new-object ...)
  1035.      * Notes:
  1036.      *   This can generate lots of garbage (if inserting NUMBERs or STRINGs).
  1037.      *   Have to put the garbage in a seprate pool so if a GC is done while
  1038.      *     I'm in the middle of the insert, they won't be collected and
  1039.      *     cause a core dump.  I'll get rid of them later.  Having the
  1040.      *     garbage in a seprate pool also makes it easy to get rid of them
  1041.      *     quickly (rather than wait for a big GC - which might be better.
  1042.      *     I don't know).
  1043.      */
  1044. static void insert_object()
  1045. {
  1046.   int n, z;
  1047.   Object *ptr;
  1048.  
  1049.   apulln(&RV,0);                /* object */
  1050.  
  1051. /* !!! check to make sure is object till compiler can do it for me! */
  1052. if (!is_object(RV.type)) MMbitch("insert-object:  Not an object!");
  1053.  
  1054.   apulln(&TV,1); n = TV.val.num;        /* n */
  1055.   for (z = 2; apulln(&TV, z++); )
  1056.   {
  1057. /* !!!??? only insert one object because can't know where object ends so can
  1058. * insert next object after it
  1059. */
  1060.     ptr = convert_to_object(tmp_object_pool, &TV);
  1061.     if (!ptr) continue;     /* !!! not convertable or out of mem. Do what? */
  1062.     OMinsert_object(RV.val.object, n++, ptr);    /* !!!error check */
  1063.   }
  1064.  
  1065.     /* free all object in the temp pool */
  1066.   OMgc_pool(tmp_object_pool, 1);    /* live (ie none) objects are marked */
  1067. }
  1068.  
  1069. static void dotok(t)
  1070. {
  1071.   int n,z;
  1072.  
  1073.   switch(t)
  1074.   {
  1075.     case ASK: mm_ask(); break;                    /* (ask prompt) */
  1076.     case MSG:                           /* (msg strings) */
  1077.       MMconcat(); MMmsg(result); RV.type = STRING; RV.val.str = result; break;
  1078.     case CONCAT:                 /* (concat string num ...) */
  1079.       MMconcat(); RV.type = STRING; RV.val.str = result; break;
  1080.     case INSERT_OBJ:  /* (insert-object object n new-object new-object ...) */
  1081.       insert_object();
  1082.       break;
  1083.     case EXTRACT_ELS:               /* (extract-elements object n z) */
  1084.       apulln(&RV,0);            /* object */
  1085.       apulln(&TV,1); n = TV.val.num;    /* n */
  1086.       apulln(&TV,2); z = TV.val.num;    /* z */
  1087.       extract_em(n,z, FALSE);
  1088.       break;
  1089.     case EXTRACT_EL:                  /* (extract-element object n) */
  1090.       apulln(&RV,0);            /* object */
  1091.       apulln(&TV,1);            /* n */
  1092.       extract_em((int)TV.val.num,1, TRUE);
  1093.       break;
  1094.     case REMOVE_ELS:                /* (remove-elements object n z) */
  1095.       apulln(&RV,0);            /* object */
  1096.       apulln(&TV,1); n = TV.val.num;    /* n */
  1097.       apulln(&TV,2); z = TV.val.num;    /* z */
  1098.  
  1099.       if (is_object(RV.type)) OMremove_items(RV.val.object,n,z);
  1100.       else MMbitch("remove-elements:  invalid type!");
  1101.  
  1102.       RV.type = VOID;    /* ??? Return removed objects? */
  1103.  
  1104.       break;
  1105.  
  1106.     default: MMbitch("phooie");
  1107.   }
  1108. }
  1109.  
  1110. /* ******************************************************************** */
  1111. /* ************************** The Front End *************************** */
  1112. /* ******************************************************************** */
  1113.  
  1114. extern maddr MMpgm_addr();        /* in mmaux() */
  1115.  
  1116.     /* Execute external code.
  1117.      * Notes
  1118.      *   Might switch blocks ie might need to change the global var and
  1119.      *     object table pointers.
  1120.      * Input:
  1121.      *   name:  name of the pgm to run.
  1122.      * Result:
  1123.      *   MMglobal_vars and MMglobal_object_table might change.
  1124.      */
  1125. static void exetern(name) char *name;    /* execute an external something */
  1126. {
  1127.   int n;
  1128.  
  1129.   if ((n = MMpgm_lookup(name)) != -1) MM(MMpgm_addr(n));
  1130.   else
  1131.     if (!MMaux_fcn(name))
  1132.     MMbitch(strcat(strcpy(result,"Can't find pgm: "),name));
  1133. }
  1134.   
  1135.     /* Load a compiled code file.
  1136.      * Code file layout:
  1137.      *   Header (see mm.h)
  1138.      *   Code
  1139.      *   Routine names (a bunch of C strings)
  1140.      *   Routine addresses
  1141.      * Notes:
  1142.      *   Need to set MMglobal_vars and MMglobal_object_table because a block
  1143.      *     lookup will not be done before we execute the MAIN code.
  1144.      *   If I can't add pgms (MMadd_pgm() complains), MMadd_pgm() needs to
  1145.      *     clean up whatever it needs to and call MMfree_block().  It can
  1146.      *     also just ignore pgms it can't add and return TRUE so that I'll
  1147.      *     go ahead and run the init code.  The problem is if there are
  1148.      *     global objects and the init code doesn't run, they might not be
  1149.      *     initialized.  At some later time a pgm in the block might be run,
  1150.      *     use a uninitialized object and the object routines might not know
  1151.      *     what to do with it (and bad things could happen).
  1152.      *   If we run out of memory or the init code doesn't run (because we
  1153.      *     ran out of memory), the global object table might not be
  1154.      *     initailized.  If we then try to free the block, we may try to
  1155.      *     free garbage and cause all kinds of problems.  A way around this
  1156.      *     is to initialize the global object table to NULL which the
  1157.      *     garbage collecters can understand (but not all the object
  1158.      *     commands can).  The local object table doesn't have this problem
  1159.      *     because it only expands as objects are placed into it (hence no
  1160.      *     junk in it).
  1161.      * Input:
  1162.      *   fname : Name of the file that has compiled Mutt code in it.  The
  1163.      *     extension is changed to .mco and the application will open it (so
  1164.      *     it can do any path searching it wants to).
  1165.      *   complain: TRUE if you want me to print a message if fname can't be
  1166.      *     opened.  All error messages (memory problems, etc) will always
  1167.      *     generate messages.
  1168.      * Returns:
  1169.      *   NULL : Couldn't open fname, out of memory, the code is out of sync
  1170.      *     with this version of MM, etc.
  1171.      *   entry_point : the address of the start up code in the loaded block.
  1172.      * Munges:
  1173.      *   MMglobal_object_table:
  1174.      *   MMglobal_vars:
  1175.      *     Points to the global var tables for the new block.  Ready to
  1176.      *     run the blocks init code.
  1177.      * Side effects:
  1178.      *   MMset_hooks() is called.
  1179.      * Notes:
  1180.      *   !!! Need to check for fread() errors!
  1181.      *   Since MMglobal_object_table and MMglobal_vars are changed, you need
  1182.      *     to set a stack frame before call this routine.
  1183.      */
  1184. #define ABC 150        /* max number of addresses in I can get per read */
  1185. maddr MMload_code(fname,complain) char *fname;
  1186. {
  1187.   extern FILE *MMopen_code_file();
  1188.  
  1189.   address z;
  1190.   char *block, *nmptr, buf[250];
  1191.   FILE *fptr;
  1192.   int j, block_id, num_pgms, num_global_objects;
  1193.   uint8 bytes[ABC*sizeof(address)], *qtr, *global_vars;
  1194.   unsigned int code_size, nmoffset, global_var_space;
  1195.   maddr code, entrypt;
  1196.   Object **global_object_table;
  1197.  
  1198.         /* open the code file */
  1199.   new_ext(buf,fname,".mco");
  1200.   if ((fptr = MMopen_code_file(buf)) == NULL)
  1201.     { if (complain) MMmoan("Can't open code file"); return NULL; }
  1202.  
  1203.         /* read and parse the header !!! error check*/
  1204.   fread((char *)bytes,1,BYTES_IN_HEADER,fptr);
  1205.  
  1206.   if (MM_MAGIC_NUMBER != GET_UINT8(&bytes[H_MAGIC_NUMBER]))
  1207.     { MMmoan("Versionits - recompile Mutt code."); goto booboo; }
  1208.  
  1209.   z =            GET_ADDRESS(&bytes[H_ENTRY_POINT]);
  1210.   code_size =        GET_UINT16 (&bytes[H_BYTES_OF_CODE]);
  1211.   nmoffset =        GET_UINT16 (&bytes[H_NAME_TABLE_OFFSET]);
  1212.   num_pgms =        GET_INT16  (&bytes[H_NUMBER_OF_PGMS]);
  1213.   global_var_space =    GET_UINT16 (&bytes[H_BYTES_OF_GVARS]);
  1214.   num_global_objects =    GET_UINT16 (&bytes[H_NUM_GLOBAL_OBJECTS]);
  1215.  
  1216.     /* set vars for error handling */
  1217.   global_object_table = NULL;
  1218.   block = NULL;
  1219.  
  1220.     /* take care of global objects: 
  1221.      *   Object *MMglobal_object_table[num_global_objects];
  1222.      * Note:  there may not be any global objects.
  1223.      * Zero out the pointers in case something fails.
  1224.      */
  1225.   if (num_global_objects && NULL == 
  1226.       (global_object_table =
  1227.     (Object **)calloc(num_global_objects, sizeof(Object *))))
  1228.   {
  1229.     MMmoan("Can't allocate global object table");
  1230.     goto booboo;
  1231.   }
  1232.   
  1233.     /* calculate size of code, name table and global vars */
  1234.   if ((block = malloc(code_size + global_var_space)) == NULL)
  1235.   {
  1236.     MMmoan("Can't malloc code");
  1237.     goto booboo;
  1238.   }
  1239.  
  1240.      /* Get the code, strings and name table.     !!! error check */
  1241.   fread(block,1,code_size,fptr);
  1242.   code        = (maddr)block;
  1243.   entrypt    = code + z;
  1244.   nmptr        = block + nmoffset;
  1245.   global_vars    = (uint8 *)(block + code_size);
  1246.  
  1247.         /* create the block name and block */
  1248.   MMblock_name(buf,fname);
  1249.   if (-1 ==
  1250.     (block_id = MMadd_block(buf,code, global_vars,
  1251.          global_object_table, num_global_objects)))
  1252.   {
  1253. booboo:
  1254.     if (global_object_table) free((char *)MMglobal_object_table);
  1255.     if (block)             free((char *)block);
  1256. booboo1:
  1257.     fclose(fptr);
  1258.     return NULL;
  1259.   }
  1260.  
  1261.         /* add routine entry points (name, block_id, address) */
  1262.   while (num_pgms)
  1263.   {
  1264.     j = (num_pgms < ABC) ? num_pgms : ABC;    /* read as many as can/left */
  1265.     num_pgms -= j; qtr = bytes;
  1266.     fread(qtr,sizeof(address),j,fptr);    /* !!! should test for NULL */
  1267.     for (; j--; qtr += sizeof(address))
  1268.     {
  1269.       z = GET_ADDRESS(qtr);    /* offset */
  1270.       if (!MMadd_pgm(nmptr, block_id, code + z)) goto booboo1;
  1271.       while (*nmptr++ != '\0') ;    /* point to next name */
  1272.     }
  1273.   }
  1274.  
  1275.         /* zero the global vars */
  1276. #if 1
  1277.   memset((char *)global_vars, 0, global_var_space);
  1278. #else
  1279.   for (j = 0; j < global_var_space; j++) global_vars[j] = 0;
  1280. #endif
  1281.  
  1282.   fclose(fptr);
  1283.  
  1284.   MMset_hooks();
  1285.  
  1286.   MMset_block(block_id);
  1287.  
  1288.   return entrypt;
  1289. }
  1290.  
  1291.     /* free the code block allocated in MMload_code() */
  1292. void MMfree_block(code, block_object_table, objects_in_table)
  1293.   maddr code;
  1294.   Object *block_object_table[];
  1295.   int objects_in_table;
  1296. {
  1297.     /* gc the block objects */
  1298.   gc_globals(block_object_table, objects_in_table);
  1299.  
  1300.   if (block_object_table) free((char *)block_object_table);
  1301.  
  1302.   free((char *)code);
  1303. }
  1304.  
  1305. /* ******************************************************************** */
  1306. /* ****************** Outside Access to Mutt Machine ****************** */
  1307. /* ******************************************************************** */
  1308.  
  1309. static jmp_buf env;
  1310. static int pgm_level = 0;   /* keep track of recursion level for setjmp */
  1311.  
  1312.     /* Is a pgm running?
  1313.      * Returns:
  1314.      *   FALSE: no pgm running.
  1315.      *   n :  n pgms are running (interrupts, (load) can cause more than one
  1316.      *          pgm to be running at the same time.
  1317.      */
  1318. MMpgm_running() { return pgm_level; }
  1319.  
  1320.     /* Execute Mutt code:  This is the front end to the Mutt Machine.  This
  1321.      *   is the ONLY routine that calls MM() other than MM itself (exetern()
  1322.      *   is considered part of MM).
  1323.      * If a child (sub pgm, etc) dies, the parent/everybody dies.
  1324.      * Input:
  1325.      *   entrypt : address of Mutt code to be executed.
  1326.      * Returns:
  1327.      *   TRUE : pgm ran to completation
  1328.      *   FALSE: pgm aborted
  1329.      * Notes:
  1330.      *   Caller MUST have set up a stack frame!
  1331.      *   Hooks or interrupts can cause this code to recurse.
  1332.      *   I am careful to save MMask_pgm from reentrent or recursive code
  1333.      *     that is run while another pgm is running.
  1334.      *   A long jump buffer is set up so we can return here if the code
  1335.      *     aborts (by calling MMabort_pgm()).
  1336.      *   This routine is not called much (only by the application to run a
  1337.      *     program) so I don't have to worry (much) about speed.
  1338.      *   When MM() returns, a complete program has run (since MM doesn't
  1339.      *     call this).
  1340.      *   After a program has finished running, need to gc, reset and
  1341.      *     generally clean up.  If recursing, only gc the local objects -
  1342.      *     can't reset because that would mess up the stack for the other
  1343.      *     running program.  When no programs are running, can reset
  1344.      *     everything.
  1345.      */
  1346. int MMexecode(entrypt) maddr entrypt;
  1347. {
  1348.   int old_ask_pgm = MMask_pgm;
  1349.  
  1350.   MMask_pgm = TRUE;
  1351.   pgm_level++;
  1352.   if (pgm_level != 1 || setjmp(env) == 0)
  1353.   {
  1354.     MM(entrypt);        /* might longjmp() */
  1355.     /* pgm ran to completion */
  1356.     pgm_level--;
  1357.     MMask_pgm = old_ask_pgm;
  1358.     pop_stkframe();
  1359.  
  1360.     if (pgm_level == 0) reset_MM(FALSE);
  1361.     else OMgc_pool(local_object_pool, 0);
  1362.  
  1363.     return TRUE;
  1364.   }
  1365.  
  1366.       /* Pgm aborted. MMabort_pgm() resets stacks, MMask_pgm, objects, etc */
  1367.   pgm_level = 0;
  1368.   return FALSE;
  1369. }
  1370.  
  1371.     /* Heres where the outside world fires off a Mutt pgm.
  1372.      * Returns FALSE if pgm aborts.
  1373.      * Note:
  1374.      *  If MMrun_pgm() gets called recursively and then aborts,
  1375.      *    everything is aborted.
  1376.      */
  1377. MMrun_pgm(n)    /* run the nth Mutt pgm */
  1378. {
  1379.   MMStkFrame mark;
  1380.  
  1381.   setframe(&mark, asp(), vsptr);
  1382.   return MMexecode(MMpgm_addr(n));
  1383. }
  1384.  
  1385.     /* Next rouines allow external things to set up a stack frame,
  1386.      *   push args, etc and then run a pgm with that frame.
  1387.      * Sequence: open frame, push args, run with args or (close frame
  1388.      *   and load).
  1389.      * Note: guard your stack frame against recursion.
  1390.      */
  1391. void MMopen_frame(mark) MMStkFrame *mark;
  1392.     { mark->startframe = asp(); mark->vsptr = vsptr; }
  1393.  
  1394. void MMpush_arg(RV) MMDatum *RV;
  1395. {
  1396.   if (RV->type == STRING) RV->val.str = pushstr(RV->val.str);
  1397.   vpush(RV);
  1398. }
  1399.  
  1400. void MMclose_frame(mark) MMStkFrame *mark;
  1401.     { setframe(mark,mark->startframe,mark->vsptr); }
  1402.  
  1403.     /* run the nth Mutt pgm with args */
  1404. MMrun_pgm_with_args(n,mark) MMStkFrame *mark;
  1405. {
  1406.   MMclose_frame(mark);
  1407.   return MMexecode(MMpgm_addr(n));
  1408. }
  1409.  
  1410.     /* Load a code file (block) and run the MAIN code.
  1411.      * Input:
  1412.      *   fname:  Name of the file that contains the code.  The application
  1413.      *     knows how to interpret this.
  1414.      *   complain:  TRUE:  Complain if can't open fname.
  1415.      * Output:
  1416.      *   TRUE:  Block loaded and MAIN code ran to completion.
  1417.      *   FALSE: Block didn't load, MAIN didn't run or something else failed.
  1418.      *        A message was probably issued.
  1419.      * Notes
  1420.      *   Maintaining a stack frame here is sometimes redundant.  If called
  1421.      *     from a pgm, the callee already has a stack frame.  When called
  1422.      *     called directly from an application, it may or may not be as a
  1423.      *     result of a running pgm.  If so, got a stack frame.  If not, a
  1424.      *     call to init_stacks() after that last pgm is run would take care
  1425.      *     of everything.
  1426.      *   Since MMload_code() changes the global var pointers, need to set up
  1427.      *     a stack frame before that call.
  1428.      */
  1429. MMload(fname,complain) char *fname;
  1430. {
  1431.   maddr entrypt;
  1432.   MMStkFrame mark;
  1433.  
  1434.   setframe(&mark,asp(),vsptr);
  1435.   if ((entrypt = MMload_code(fname,complain)) != NULL)
  1436.     return MMexecode(entrypt);
  1437.  
  1438.   pop_stkframe();    /* didn't load code: reset global var pointers */
  1439.  
  1440.   return FALSE;
  1441. }
  1442.  
  1443.     /* Initialize the Mutt Machine.  This is called by the application ONCE
  1444.      *   so MM can set things up.
  1445.      * Call this AFTER everything else in your application has been
  1446.      *   initialized (this might call back into the application).
  1447.      * Returns:
  1448.      *   TRUE:  everything went as expected.
  1449.      *   FALSE:  Mutt Machine can't be initialized, don't use it!
  1450.      */
  1451. int MMinitialize()
  1452. {
  1453.   init_stacks();
  1454.  
  1455.   if (!(local_object_pool  = OMcreate_object_pool(local_gc_marker))    ||
  1456.       !(global_object_pool = OMcreate_object_pool((pfi)NULL))        ||
  1457.       !(tmp_object_pool    = OMcreate_object_pool((pfi)NULL)))
  1458.     return FALSE;
  1459.  
  1460. /* ??? malloc result? */
  1461.  
  1462.   return TRUE;
  1463. }
  1464.  
  1465. /* ******************************************************************** */
  1466. /* ****************** Error handling ********************************** */
  1467. /* ******************************************************************** */
  1468.  
  1469.     /* dump levels:
  1470.      *  0 - No nuthin
  1471.      *  n - Implementer defined
  1472.      */
  1473. void MMabort_pgm(dump_level)
  1474. {
  1475. /*  if (dump_level) MMtrace_back(dump_level);    /* ??? */
  1476. #if 0
  1477.   if (dump_level)
  1478.   {
  1479.     int n = 0;
  1480.     MMStkFrame *mark;
  1481.  
  1482.     mark = prev_stkframe;
  1483. /* how tell if current frame && prev frame same??? */
  1484.     if (pcat() != mark->pc || MMcurrent_block != mark->block_id)
  1485.       MMtrace_back(0, n++, MMcurrent_block, pcat());    /*  */
  1486.     for (mark = prev_stkframe; mark; mark = mark->prev_stkframe)
  1487.     {
  1488.       if (0 == mark->pc) break;
  1489.       MMtrace_back(1, n++, mark->block_id, mark->pc);
  1490.     }
  1491.   }
  1492. #endif
  1493.   reset_MM(TRUE);
  1494.   longjmp(env,1);
  1495. }
  1496.