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