home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v92.tgz / v92.tar / v92 / src / runtime / rmemmgt.r < prev    next >
Text File  |  1996-03-22  |  46KB  |  1,492 lines
  1. /*
  2.  * File: rmemmgt.r
  3.  *  Contents: block description arrays, memory initialization,
  4.  *   garbage collection, dump routines
  5.  */
  6.  
  7. #ifdef CRAY
  8. #include <malloc.h>
  9. #endif                    /* CRAY */
  10.  
  11. /*
  12.  * Prototypes
  13.  */
  14. hidden novalue postqual        Params((dptr dp));
  15. hidden novalue markblock    Params((dptr dp));
  16. hidden novalue markptr        Params((union block **ptr));
  17. hidden novalue sweep        Params((struct b_coexpr *ce));
  18. hidden novalue sweep_stk    Params((struct b_coexpr *ce));
  19. hidden novalue reclaim        Params((noargs));
  20. hidden novalue cofree        Params((noargs));
  21. hidden novalue scollect        Params((word extra));
  22. hidden int     qlcmp        Params((dptr  *q1,dptr  *q2));
  23. hidden novalue adjust        Params((char *source, char *dest));
  24. hidden novalue compact        Params((char *source));
  25. hidden novalue mvc        Params((uword n, char *src, char *dest));
  26.  
  27. #ifdef MultiThread
  28. hidden novalue markprogram    Params((struct progstate *pstate));
  29. #endif                    /*MultiThread*/
  30.  
  31. /*
  32.  * Variables
  33.  */
  34.  
  35. #ifndef MultiThread
  36. word coll_stat = 0;             /* collections in static region */
  37. word coll_str = 0;              /* collections in string region */
  38. word coll_blk = 0;              /* collections in block region */
  39. word coll_tot = 0;              /* total collections */
  40. #endif                /* MultiThread */
  41. word alcnum = 0;                /* co-expressions allocated since g.c. */
  42.  
  43. dptr *quallist;                 /* string qualifier list */
  44. dptr *qualfree;                 /* qualifier list free pointer */
  45. dptr *equallist;                /* end of qualifier list */
  46.  
  47. int qualfail;                   /* flag: qualifier list overflow */
  48.  
  49. /*
  50.  *
  51.  * Note: function calls beginning with "MM" are just empty macros
  52.  * unless EventMon is defined.
  53.  */
  54.  
  55. /*
  56.  * Allocated block size table (sizes given in bytes).  A size of -1 is used
  57.  *  for types that have no blocks; a size of 0 indicates that the
  58.  *  second word of the block contains the size; a value greater than
  59.  *  0 is used for types with constant sized blocks.
  60.  */
  61.  
  62. int bsizes[] = {
  63.     -1,                       /* T_Null (0), not block */
  64.     -1,                       /* T_Integer (1), not block */
  65.      0,                       /* T_Lrgint (2), large integer */
  66.      sizeof(struct b_real),   /* T_Real (3), real number */
  67.      sizeof(struct b_cset),   /* T_Cset (4), cset */
  68.      sizeof(struct b_file),   /* T_File (5), file block */
  69.      0,                       /* T_Proc (6), procedure block */
  70.      0,                       /* T_Record (7), record block */
  71.      sizeof(struct b_list),   /* T_List (8), list header block */
  72.      0,                       /* T_Lelem (9), list element block */
  73.      sizeof(struct b_set),    /* T_Set (10), set header block */
  74.      sizeof(struct b_selem),  /* T_Selem (11), set element block */
  75.      sizeof(struct b_table),  /* T_Table (12), table header block */
  76.      sizeof(struct b_telem),  /* T_Telem (13), table element block */
  77.      sizeof(struct b_tvtbl),  /* T_Tvtbl (14), table element trapped variable */
  78.      0,                       /* T_Slots (15), set/table hash block */
  79.      sizeof(struct b_tvsubs), /* T_Tvsubs (16), substring trapped variable */
  80.      0,                       /* T_Refresh (17), refresh block */
  81.     -1,                       /* T_Coexpr (18), co-expression block */
  82.      0,                       /* T_External (19) external block */
  83.      -1,                      /* T_Kywdint (20), integer keyword variable */
  84.      -1,                      /* T_Kywdpos (21), keyword &pos */
  85.      -1,                      /* T_Kywdsubj (22), keyword &subject */
  86.      -1,                      /* T_Kywdwin (23), keyword &window */
  87.      -1,                      /* T_Kywdstr (24), string keyword variable */
  88.      -1,                      /* T_Kywdevent (25), event keyword variable */
  89.     };
  90.  
  91. /*
  92.  * Table of offsets (in bytes) to first descriptor in blocks.  -1 is for
  93.  *  types not allocated, 0 for blocks with no descriptors.
  94.  */
  95. int firstd[] = {
  96.     -1,                       /* T_Null (0), not block */
  97.     -1,                       /* T_Integer (1), not block */
  98.      0,                       /* T_Lrgint (2), large integer */
  99.      0,                       /* T_Real (3), real number */
  100.      0,                       /* T_Cset (4), cset */
  101.      3*WordSize,              /* T_File (5), file block */
  102.  
  103. #ifdef MultiThread
  104.      8*WordSize,              /* T_Proc (6), procedure block */
  105. #else                /* MultiThread */
  106.      7*WordSize,              /* T_Proc (6), procedure block */
  107. #endif                /* MultiThread */
  108.  
  109.      4*WordSize,              /* T_Record (7), record block */
  110.      0,                       /* T_List (8), list header block */
  111.      7*WordSize,              /* T_Lelem (9), list element block */
  112.      0,                       /* T_Set (10), set header block */
  113.      3*WordSize,              /* T_Selem (11), set element block */
  114.      (4+HSegs)*WordSize,      /* T_Table (12), table header block */
  115.      3*WordSize,              /* T_Telem (13), table element block */
  116.      3*WordSize,              /* T_Tvtbl (14), table element trapped variable */
  117.      0,                       /* T_Slots (15), set/table hash block */
  118.      3*WordSize,              /* T_Tvsubs (16), substring trapped variable */
  119.  
  120. #if COMPILER
  121.      2*WordSize,              /* T_Refresh (17), refresh block */
  122. #else                /* COMPILER */
  123.      (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */
  124. #endif                /* COMPILER */
  125.  
  126.     -1,                       /* T_Coexpr (18), co-expression block */
  127.      0,                       /* T_External (19), external block */
  128.      -1,                      /* T_Kywdint (20), integer keyword variable */
  129.      -1,                      /* T_Kywdpos (21), keyword &pos */
  130.      -1,                      /* T_Kywdsubj (22), keyword &subject */
  131.      -1,                      /* T_Kywdwin (23), keyword &window */
  132.      -1,                      /* T_Kywdstr (24), string keyword variable */
  133.      -1,                      /* T_Kywdevent (25), event keyword variable */
  134.     };
  135.  
  136. /*
  137.  * Table of offsets (in bytes) to first pointer in blocks.  -1 is for
  138.  *  types not allocated, 0 for blocks with no pointers.
  139.  */
  140. int firstp[] = {
  141.     -1,                       /* T_Null (0), not block */
  142.     -1,                       /* T_Integer (1), not block */
  143.      0,                       /* T_Lrgint (2), large integer */
  144.      0,                       /* T_Real (3), real number */
  145.      0,                       /* T_Cset (4), cset */
  146.      0,                       /* T_File (5), file block */
  147.      0,                       /* T_Proc (6), procedure block */
  148.      3*WordSize,              /* T_Record (7), record block */
  149.      3*WordSize,              /* T_List (8), list header block */
  150.      2*WordSize,              /* T_Lelem (9), list element block */
  151.      4*WordSize,              /* T_Set (10), set header block */
  152.      1*WordSize,              /* T_Selem (11), set element block */
  153.      4*WordSize,              /* T_Table (12), table header block */
  154.      1*WordSize,              /* T_Telem (13), table element block */
  155.      1*WordSize,              /* T_Tvtbl (14), table element trapped variable */
  156.      2*WordSize,              /* T_Slots (15), set/table hash block */
  157.      0,                       /* T_Tvsubs (16), substring trapped variable */
  158.      0,                       /* T_Refresh (17), refresh block */
  159.     -1,                       /* T_Coexpr (18), co-expression block */
  160.      0,                       /* T_External (19), external block */
  161.      -1,                      /* T_Kywdint (20), integer keyword variable */
  162.      -1,                      /* T_Kywdpos (21), keyword &pos */
  163.      -1,                      /* T_Kywdsubj (22), keyword &subject */
  164.      -1,                      /* T_Kywdwin (23), keyword &window */
  165.      -1,                      /* T_Kywdstr (24), string keyword variable */
  166.      -1,                      /* T_Kywdevent (25), event keyword variable */
  167.     };
  168.  
  169. /*
  170.  * Table of number of pointers in blocks.  -1 is for types not allocated and
  171.  *  types without pointers, 0 for pointers through the end of the block.
  172.  */
  173. int ptrno[] = {
  174.     -1,                       /* T_Null (0), not block */
  175.     -1,                       /* T_Integer (1), not block */
  176.     -1,                       /* T_Lrgint (2), large integer */
  177.     -1,                       /* T_Real (3), real number */
  178.     -1,                       /* T_Cset (4), cset */
  179.     -1,                       /* T_File (5), file block */
  180.     -1,                       /* T_Proc (6), procedure block */
  181.      1,                       /* T_Record (7), record block */
  182.      2,                       /* T_List (8), list header block */
  183.      2,                       /* T_Lelem (9), list element block */
  184.      HSegs,                   /* T_Set (10), set header block */
  185.      1,                       /* T_Selem (11), set element block */
  186.      HSegs,                   /* T_Table (12), table header block */
  187.      1,                       /* T_Telem (13), table element block */
  188.      1,                       /* T_Tvtbl (14), table element trapped variable */
  189.      0,                       /* T_Slots (15), set/table hash block */
  190.     -1,                       /* T_Tvsubs (16), substring trapped variable */
  191.     -1,                       /* T_Refresh (17), refresh block */
  192.     -1,                       /* T_Coexpr (18), co-expression block */
  193.     -1,                       /* T_External (19), external block */
  194.     -1,                       /* T_Kywdint (20), integer keyword variable */
  195.     -1,                       /* T_Kywdpos (21), keyword &pos */
  196.     -1,                       /* T_Kywdsubj (22), keyword &subject */
  197.     -1,                       /* T_Kywdwin (23), keyword &window */
  198.     -1,                       /* T_Kywdstr (24), string keyword variable */
  199.     -1,                       /* T_Kywdevent (25), event keyword variable */
  200.     };
  201.  
  202. /*
  203.  * Table of block names used by debugging functions.
  204.  */
  205. char *blkname[] = {
  206.    "illegal object",                    /* T_Null (0), not block */
  207.    "illegal object",                    /* T_Integer (1), not block */
  208.    "large integer",                     /* T_Largint (2) */
  209.    "real number",                       /* T_Real (3) */
  210.    "cset",                              /* T_Cset (4) */
  211.    "file",                              /* T_File (5) */
  212.    "procedure",                         /* T_Proc (6) */
  213.    "record",                            /* T_Record (7) */
  214.    "list",                              /* T_List (8) */
  215.    "list element",                      /* T_Lelem (9) */
  216.    "set",                               /* T_Set (10) */
  217.    "set element",                       /* T_Selem (11) */
  218.    "table",                             /* T_Table (12) */
  219.    "table element",                     /* T_Telem (13) */
  220.    "table element trapped variable",    /* T_Tvtbl (14) */
  221.    "hash block",                        /* T_Slots (15) */
  222.    "substring trapped variable",        /* T_Tvsubs (16) */
  223.    "refresh block",                     /* T_Refresh (17) */
  224.    "co-expression",                     /* T_Coexpr (18) */
  225.    "external block",                    /* T_External (19) */
  226.    "integer keyword variable",          /* T_Kywdint (20) */
  227.    "&pos",                              /* T_Kywdpos (21) */
  228.    "&subject",                          /* T_Kywdsubj (22) */
  229.    "illegal object",                    /* T_Kywdwin (23) */
  230.    "illegal object",                    /* T_Kywdstr (24) */
  231.    "illegal object",                    /* T_Kywdevent (25) */
  232.    };
  233.  
  234. /*
  235.  * Sizes of hash chain segments.
  236.  *  Table size must equal or exceed HSegs.
  237.  */
  238. uword segsize[] = {
  239.    ((uword)HSlots),            /* segment 0 */
  240.    ((uword)HSlots),            /* segment 1 */
  241.    ((uword)HSlots) << 1,        /* segment 2 */
  242.    ((uword)HSlots) << 2,        /* segment 3 */
  243.    ((uword)HSlots) << 3,        /* segment 4 */
  244.    ((uword)HSlots) << 4,        /* segment 5 */
  245.    ((uword)HSlots) << 5,        /* segment 6 */
  246.    ((uword)HSlots) << 6,        /* segment 7 */
  247.    ((uword)HSlots) << 7,        /* segment 8 */
  248.    ((uword)HSlots) << 8,        /* segment 9 */
  249.    ((uword)HSlots) << 9,        /* segment 10 */
  250.    ((uword)HSlots) << 10,        /* segment 11 */
  251.    };
  252.  
  253. /*
  254.  * initalloc - initialization routine to allocate memory regions
  255.  */
  256.  
  257. #if COMPILER
  258. novalue initalloc()
  259.    {
  260.  
  261. #else                    /* COMPILER */
  262. #ifdef MultiThread
  263. novalue initalloc(codesize,p)
  264. struct progstate *p;
  265. #else                    /* MultiThread */
  266. novalue initalloc(codesize)
  267. #endif                    /* MultiThread */
  268. word codesize;
  269.    {
  270. #ifdef MultiThread
  271.    struct region *ps, *pb;
  272. #endif
  273.  
  274.    if ((uword)codesize > (unsigned)MaxBlock)
  275.       error(NULL, "icode file too large");
  276.    /*
  277.     * Allocate icode region
  278.     */
  279. #ifdef MultiThread
  280.    if (codesize)
  281. #endif                    /* MultiThread */
  282.    if ((code = (char *)AllocReg(codesize)) == NULL)
  283.       error(NULL,
  284.      "insufficient memory, corrupted icode file, or wrong platform");
  285. #endif                    /* COMPILER */
  286.  
  287.    /*
  288.     * Set up allocated memory.    The regions are:
  289.     *    Static memory region (not used)
  290.     *    Allocated string region
  291.     *    Allocate block region
  292.     *    Qualifier list
  293.     */
  294.  
  295. #ifdef MultiThread
  296.    ps = p->stringregion;
  297.    ps->free = ps->base = (char *)AllocReg(ps->size);
  298.    if (ps->free == NULL)
  299.       error(NULL, "insufficient memory for string region");
  300.    ps->end = ps->base + ps->size;
  301.  
  302.    pb = p->blockregion;
  303.    pb->free = pb->base = (char *)AllocReg(pb->size);
  304.    if (pb->free == NULL)
  305.       error(NULL, "insufficient memory for block region");
  306.    pb->end = pb->base + pb->size;
  307.  
  308.    if (p == &rootpstate) {
  309.       if ((quallist = (dptr *)malloc(qualsize)) == NULL)
  310.          error(NULL, "insufficient memory for qualifier list");
  311.       equallist = (dptr *)((char *)quallist + qualsize);
  312.       }
  313. #else                    /* MultiThread */
  314.    {
  315.    uword t1, t2;
  316.    t1 = ssize;
  317.    t2 = abrsize;
  318.    curstring = (struct region *)malloc(sizeof(struct region));
  319.    curblock = (struct region *)malloc(sizeof(struct region));
  320.    curstring->size = t1;
  321.    curblock->size = t2;
  322.    }
  323.    curstring->next = curstring->prev = NULL;
  324.    curstring->Gnext = curstring->Gprev = NULL;
  325.    curblock->next = curblock->prev = NULL;
  326.    curblock->Gnext = curblock->Gprev = NULL;
  327.    if ((strfree = strbase = (char *)AllocReg(ssize)) == NULL)
  328.       error(NULL, "insufficient memory for string region");
  329.    strend = strbase + ssize;
  330.    if ((blkfree = blkbase = (char *)AllocReg(abrsize)) == NULL)
  331.       error(NULL, "insufficient memory for block region");
  332.    blkend = blkbase + abrsize;
  333.    if ((quallist = (dptr *)malloc(qualsize)) == NULL)
  334.       error(NULL, "insufficient memory for qualifier list");
  335.    equallist = (dptr *)((char *)quallist + qualsize);
  336. #endif                    /* MultiThread */
  337.    }
  338.  
  339. /*
  340.  * collect - do a garbage collection of currently active regions.
  341.  */
  342.  
  343. int collect(region)
  344. int region;
  345.    {
  346.    struct b_coexpr *cp;
  347.  
  348. #ifdef EventMon
  349.    if (!noMTevents)
  350.       EVVal((word)region,E_Collect);
  351. #endif                    /* EventMon */
  352.  
  353.    switch (region) {
  354.       case Static:
  355.          coll_stat++;
  356.          break;
  357.       case Strings:
  358.          coll_str++;
  359.          break;
  360.       case Blocks:  
  361.          coll_blk++;
  362.          break;
  363.       }
  364.    coll_tot++;
  365.  
  366.    alcnum = 0;
  367.  
  368.    /*
  369.     * Garbage collection cannot be done until initialization is complete.
  370.     */
  371.  
  372. #if !COMPILER
  373.    if (sp == NULL)
  374.       return 0;
  375. #endif                    /* !COMPILER */
  376.  
  377. #if MACINTOSH
  378. #if MPW
  379.    {
  380.       void SetWatchCursor(void);
  381.       SetWatchCursor();
  382.       }
  383. #endif                    /* MPW */
  384. #endif                    /* MACINTOSH */
  385.  
  386.    /*
  387.     * Sync the values (used by sweep) in the coexpr block for ¤t
  388.     *  with the current values.
  389.     */
  390.    cp = (struct b_coexpr *)BlkLoc(k_current);
  391.    cp->es_tend = tend;
  392.  
  393. #if !COMPILER
  394.    cp->es_pfp = pfp;
  395.    cp->es_gfp = gfp;
  396.    cp->es_efp = efp;
  397.    cp->es_sp = sp;
  398. #endif                    /* !COMPILER */
  399.  
  400.    /*
  401.     * Reset qualifier list.
  402.     */
  403.    qualfree = quallist;
  404.    qualfail = 0;
  405.  
  406.    /*
  407.     * Mark the stacks for &main and the current co-expression.
  408.     */
  409. #ifdef MultiThread
  410.    markprogram(&rootpstate);
  411. #endif                    /* MultiThread */
  412.    markblock(&k_main);
  413.    markblock(&k_current);
  414.    /*
  415.     * Mark &subject and the cached s2 and s3 strings for map.
  416.     */
  417. #ifndef MultiThread
  418.    postqual(&k_subject);
  419.    postqual(&kywd_prog);
  420. #endif                    /* MultiThread */
  421.    if (Qual(maps2))                     /*  caution: the cached arguments of */
  422.       postqual(&maps2);                 /*  map may not be strings. */
  423.    else if (Pointer(maps2))
  424.       markblock(&maps2);
  425.    if (Qual(maps3))
  426.       postqual(&maps3);
  427.    else if (Pointer(maps3))
  428.       markblock(&maps3);
  429.  
  430. #ifdef Graphics
  431.    /*
  432.     * Mark file and list values for windows
  433.     */
  434.    {
  435.      wsp ws;
  436.  
  437.      for (ws = wstates; ws ; ws = ws->next) {
  438.         if (is:file(ws->filep))
  439.           markblock(&(ws->filep));
  440.         if (is:list(ws->listp))
  441.           markblock(&(ws->listp));
  442.         }
  443.    }
  444. #endif                    /* Graphics */
  445.  
  446.    /*
  447.     * Mark the globals and the statics.
  448.     */
  449.  
  450. #ifndef MultiThread
  451.    { register struct descrip *dp;
  452.    for (dp = globals; dp < eglobals; dp++)
  453.       if (Qual(*dp))
  454.      postqual(dp);
  455.       else if (Pointer(*dp))
  456.      markblock(dp);
  457.  
  458.    for (dp = statics; dp < estatics; dp++)
  459.       if (Qual(*dp))
  460.      postqual(dp);
  461.       else if (Pointer(*dp))
  462.      markblock(dp);
  463.    }
  464.  
  465. #ifdef Graphics
  466.    if (is:file(kywd_xwin[XKey_Window]))
  467.       markblock(&(kywd_xwin[XKey_Window]));
  468.    if (is:file(lastEventWin))
  469.       markblock(&(lastEventWin));
  470. #endif                    /* Graphics */
  471. #endif                    /* MultiThread */
  472.  
  473.    reclaim();
  474.  
  475.    /*
  476.     * Turn off all the marks in all the block regions everywhere
  477.     */
  478.    { struct region *br;
  479.    for (br = curblock->Gnext; br; br = br->Gnext) {
  480.       char *source = br->base, *free = br->free;
  481.       uword NoMark = ~F_Mark;
  482.       while (source < free) {
  483.      BlkType(source) &= NoMark;
  484.          source += BlkSize(source);
  485.          }
  486.       }
  487.    for (br = curblock->Gprev; br; br = br->Gprev) {
  488.       char *source = br->base, *free = br->free;
  489.       uword NoMark = ~F_Mark;
  490.       while (source < free) {
  491.      BlkType(source) &= NoMark;
  492.          source += BlkSize(source);
  493.          }
  494.       }
  495.    }
  496.  
  497. #ifdef EventMon
  498.    if (!noMTevents) {
  499.       mmrefresh();
  500.       EVValD(&nulldesc, E_EndCollect);
  501.       }
  502. #endif                    /* EventMon */
  503.  
  504.    return 1;
  505.    }
  506.  
  507. /*
  508.  * markprogram - traverse pointers out of a program state structure
  509.  */
  510.  
  511. #ifdef MultiThread
  512. #define PostDescrip(d) \
  513.    if (Qual(d)) \
  514.       postqual(&(d)); \
  515.    else if (Pointer(d))\
  516.       markblock(&(d));
  517.  
  518. static novalue markprogram(pstate)
  519. struct progstate *pstate;
  520.    {
  521.    struct descrip *dp;
  522.  
  523.    PostDescrip(pstate->parentdesc);
  524.    PostDescrip(pstate->eventmask);
  525.    PostDescrip(pstate->opcodemask);
  526.    PostDescrip(pstate->eventcode);
  527.    PostDescrip(pstate->eventval);
  528.    PostDescrip(pstate->eventsource);
  529.  
  530.    /* Kywd_err, &error, always an integer */
  531.    /* Kywd_pos, &pos, always an integer */
  532.    postqual(&(pstate->ksub));
  533.    postqual(&(pstate->Kywd_prog));
  534.    /* Kywd_ran, &random, always an integer */
  535.    /* Kywd_trc, &trace, always an integer */
  536.  
  537.    /*
  538.     * Mark the globals and the statics.
  539.     */
  540.    for (dp = pstate->Globals; dp < pstate->Eglobals; dp++)
  541.       if (Qual(*dp))
  542.      postqual(dp);
  543.       else if (Pointer(*dp))
  544.      markblock(dp);
  545.  
  546.    for (dp = pstate->Statics; dp < pstate->Estatics; dp++)
  547.       if (Qual(*dp))
  548.      postqual(dp);
  549.       else if (Pointer(*dp))
  550.      markblock(dp);
  551.  
  552.    /*
  553.     * no marking for &x, &y, &row, &col, &interval, all integers
  554.     */
  555. #ifdef Graphics
  556.    PostDescrip(pstate->LastEventWin);    /* last Event() win */
  557.    PostDescrip(pstate->Kywd_xwin[XKey_Window]);    /* &window */
  558. #endif                    /* Graphics */
  559.  
  560.    PostDescrip(pstate->K_errorvalue);
  561.    PostDescrip(pstate->T_errorvalue);
  562.    }
  563. #endif                    /* MultiThread */
  564.  
  565. /*
  566.  * postqual - mark a string qualifier.  Strings outside the string space
  567.  *  are ignored.
  568.  */
  569.  
  570. static novalue postqual(dp)
  571. dptr dp;
  572.    {
  573.    char *newqual;
  574.  
  575. #ifdef CRAY
  576.    if (strbase <= StrLoc(*dp) && StrLoc(*dp) < (strfree + 1)) {
  577. #else                    /* CRAY */
  578.    if (InRange(strbase,StrLoc(*dp),strfree + 1)) { 
  579. #endif                    /* CRAY */
  580.  
  581.       /*
  582.        * The string is in the string space.  Add it to the string qualifier
  583.        *  list, but before adding it, expand the string qualifier list if
  584.        *  necessary.
  585.        */
  586.       if (qualfree >= equallist) {
  587.  
  588.      /* reallocate a new qualifier list that's twice as large */
  589.      newqual = (char *)realloc((char *)quallist, (msize)(2 * qualsize));
  590.      if (newqual) {
  591.         quallist = (dptr *)newqual;
  592.         qualfree = (dptr *)(newqual + qualsize);
  593.         qualsize *= 2;
  594.         equallist = (dptr *)(newqual + qualsize);
  595.         }
  596.      else {
  597.             qualfail = 1;
  598.             return;
  599.         }
  600.  
  601.          }
  602.       *qualfree++ = dp;
  603.       }
  604.    }
  605.  
  606. /*
  607.  * markblock - mark each accessible block in the block region and build
  608.  *  back-list of descriptors pointing to that block. (Phase I of garbage
  609.  *  collection.)
  610.  */
  611. static novalue markblock(dp)
  612. dptr dp;
  613.    {
  614.    register dptr dp1;
  615.    register char *block, *endblock;
  616.    word type, fdesc;
  617.    int numptr;
  618.    register union block **ptr, **lastptr;
  619.  
  620.    if (Var(*dp)) {
  621.        if (dp->dword & F_Typecode) {
  622.           switch (Type(*dp)) {
  623.              case T_Kywdint:
  624.              case T_Kywdpos:
  625.              case T_Kywdsubj:
  626.                 /*
  627.                  * The descriptor points to a keyword, not a block.
  628.                  */
  629.                 return;
  630.              }
  631.           }
  632.        else if (Offset(*dp) == 0) {
  633.           /*
  634.            * The descriptor is a simple variable not residing in a block.
  635.            */
  636.           return;
  637.           }
  638.       }
  639.  
  640.    /*
  641.     * Get the block to which dp points.
  642.     */
  643.    block = (char *)BlkLoc(*dp);
  644.  
  645.    if (InRange(blkbase,block,blkfree)) {
  646.       type = BlkType(block);
  647.       if ((uword)type <= MaxType) {
  648.  
  649.          /*
  650.           * The type is valid, which indicates that this block has not
  651.           *  been marked.  Point endblock to the byte past the end
  652.           *  of the block.
  653.           */
  654.          endblock = block + BlkSize(block);
  655.          }
  656.  
  657.       /*
  658.        * Add dp to the back chain for the block and point the
  659.        *  block (via the type field) to dp.vword.
  660.        */
  661.       BlkLoc(*dp) = (union block *)type;
  662.       BlkType(block) = (uword)&BlkLoc(*dp);
  663.  
  664.       if ((uword)type <= MaxType) {
  665.          /*
  666.           * The block was not marked; process pointers and descriptors
  667.           *  within the block.
  668.           */
  669.          if ((fdesc = firstp[type]) > 0) {
  670.             /*
  671.              * The block contains pointers; mark each pointer.
  672.              */
  673.             ptr = (union block **)(block + fdesc);
  674.         numptr = ptrno[type];
  675.         if (numptr > 0)
  676.            lastptr = ptr + numptr;
  677.         else
  678.            lastptr = (union block **)endblock;
  679.         for (; ptr < lastptr; ptr++)
  680.            if (*ptr != NULL)
  681.                   markptr(ptr);
  682.         }
  683.          if ((fdesc = firstd[type]) > 0)
  684.             /*
  685.              * The block contains descriptors; mark each descriptor.
  686.              */
  687.             for (dp1 = (dptr)(block + fdesc);
  688.                  (char *)dp1 < endblock; dp1++) {
  689.                if (Qual(*dp1))
  690.                   postqual(dp1);
  691.                else if (Pointer(*dp1))
  692.                   markblock(dp1);
  693.                }
  694.          }
  695.       }
  696.  
  697.    else if ((unsigned int)BlkType(block) == T_Coexpr) {
  698.       struct b_coexpr *cp;
  699.       struct astkblk *abp;
  700.       int i;
  701.       struct descrip adesc;
  702.  
  703.       /*
  704.        * dp points to a co-expression block that has not been
  705.        *  marked.  Point the block to dp.  Sweep the interpreter
  706.        *  stack in the block.  Then mark the block for the
  707.        *  activating co-expression and the refresh block.
  708.        */
  709.       BlkType(block) = (uword)dp;
  710.       sweep((struct b_coexpr *)block);
  711.  
  712. #ifdef MultiThread
  713.       if (((struct b_coexpr *)block)+1 ==
  714.          (struct b_coexpr *)((struct b_coexpr *)block)->program){
  715.          /*
  716.           * This coexpr is an &main; traverse its roots
  717.           */
  718.          markprogram(((struct b_coexpr *)block)->program);
  719.          }
  720. #endif                    /* MultiThread */
  721.  
  722. #ifdef Coexpr
  723.       /*
  724.        * Mark the activators of this co-expression.   The activators are
  725.        *  stored as a list of addresses, but markblock requires the address
  726.        *  of a descriptor.  To accommodate markblock, the dummy descriptor
  727.        *  adesc is filled in with each activator address in turn and then
  728.        *  marked.  Since co-expressions and the descriptors that reference
  729.        *  them don't participate in the back-chaining scheme, it's ok to
  730.        *  reuse the descriptor in this manner.
  731.        */
  732.       cp = (struct b_coexpr *)block;
  733.       adesc.dword = D_Coexpr;
  734.       for (abp = cp->es_actstk; abp != NULL; abp = abp->astk_nxt) {
  735.          for (i = 1; i <= abp->nactivators; i++) {
  736.             BlkLoc(adesc) = (union block *)abp->arec[i-1].activator;
  737.             markblock(&adesc);
  738.             }
  739.          }
  740.       if(BlkLoc(cp->freshblk) != NULL)
  741.          markblock(&((struct b_coexpr *)block)->freshblk);
  742. #endif                                  /* Coexpr */
  743.       }
  744.  
  745.    else {
  746.       struct region *rp;
  747.  
  748.       /*
  749.        * Look for this block in other allocated block regions.
  750.        */
  751.       for (rp = curblock->Gnext; rp; rp = rp->Gnext)
  752.      if (InRange(rp->base,block,rp->free)) break;
  753.  
  754.       if (rp == NULL)
  755.          for (rp = curblock->Gprev; rp; rp = rp->Gprev)
  756.             if (InRange(rp->base,block,rp->free)) break;
  757.  
  758.       /*
  759.        * If this block is not in a block region, its something else
  760.        *  like a procedure block.
  761.        */
  762.       if (rp == NULL)
  763.          return;
  764.  
  765.       /*
  766.        * Get this block's type field; return if it is marked
  767.        */
  768.       type = BlkType(block);
  769.       if ((uword)type > MaxType)
  770.          return;
  771.  
  772.       /*
  773.        * this is an unmarked block outside the (collecting) block region;
  774.        * process pointers and descriptors within the block.
  775.        *
  776.        * The type is valid, which indicates that this block has not
  777.        *  been marked.  Point endblock to the byte past the end
  778.        *  of the block.
  779.        */
  780.       endblock = block + BlkSize(block);
  781.  
  782.       BlkType(block) |= F_Mark;            /* mark the block */
  783.  
  784.       if ((fdesc = firstp[type]) > 0) {
  785.          /*
  786.           * The block contains pointers; mark each pointer.
  787.           */
  788.          ptr = (union block **)(block + fdesc);
  789.      numptr = ptrno[type];
  790.      if (numptr > 0)
  791.         lastptr = ptr + numptr;
  792.      else
  793.         lastptr = (union block **)endblock;
  794.      for (; ptr < lastptr; ptr++)
  795.         if (*ptr != NULL)
  796.                markptr(ptr);
  797.      }
  798.       if ((fdesc = firstd[type]) > 0)
  799.          /*
  800.           * The block contains descriptors; mark each descriptor.
  801.           */
  802.          for (dp1 = (dptr)(block + fdesc);
  803.               (char *)dp1 < endblock; dp1++) {
  804.             if (Qual(*dp1))
  805.                postqual(dp1);
  806.             else if (Pointer(*dp1))
  807.                markblock(dp1);
  808.             }
  809.       }
  810.    }
  811.  
  812. /*
  813.  * markptr - just like mark block except the object pointing at the block
  814.  *  is just a block pointer, not a descriptor.
  815.  */
  816.  
  817. static novalue markptr(ptr)
  818. union block **ptr;
  819.    {
  820.    register dptr dp;
  821.    register char *block, *endblock;
  822.    word type, fdesc;
  823.    int numptr;
  824.    register union block **ptr1, **lastptr;
  825.  
  826.    /*
  827.     * Get the block to which ptr points.
  828.     */
  829.    block = (char *)*ptr;
  830.    if (InRange(blkbase,block,blkfree)) {
  831.       type = BlkType(block);
  832.       if ((uword)type <= MaxType) {
  833.          /*
  834.           * The type is valid, which indicates that this block has not
  835.           *  been marked.  Point endblock to the byte past the end
  836.           *  of the block.
  837.           */
  838.          endblock = block + BlkSize(block);
  839.          }
  840.  
  841.       /*
  842.        * Add ptr to the back chain for the block and point the
  843.        *  block (via the type field) to ptr.
  844.        */
  845.       *ptr = (union block *)type;
  846.       BlkType(block) = (uword)ptr;
  847.  
  848.       if ((uword)type <= MaxType) {
  849.          /*
  850.           * The block was not marked; process pointers and descriptors
  851.           *  within the block.
  852.           */
  853.          if ((fdesc = firstp[type]) > 0) {
  854.             /*
  855.              * The block contains pointers; mark each pointer.
  856.              */
  857.             ptr1 = (union block **)(block + fdesc);
  858.             numptr = ptrno[type];
  859.             if (numptr > 0)
  860.                lastptr = ptr1 + numptr;
  861.             else
  862.                lastptr = (union block **)endblock;
  863.             for (; ptr1 < lastptr; ptr1++)
  864.                if (*ptr1 != NULL)
  865.                   markptr(ptr1);
  866.             }
  867.          if ((fdesc = firstd[type]) > 0)
  868.             /*
  869.              * The block contains descriptors; mark each descriptor.
  870.              */
  871.             for (dp = (dptr)(block + fdesc);
  872.                  (char *)dp < endblock; dp++) {
  873.                if (Qual(*dp))
  874.                   postqual(dp);
  875.                else if (Pointer(*dp))
  876.                   markblock(dp);
  877.                }
  878.          }
  879.       }
  880.  
  881.    else {
  882.       struct region *rp;
  883.  
  884.       /*
  885.        * Look for this block in other allocated block regions.
  886.        */
  887.       for (rp = curblock->Gnext;rp;rp = rp->Gnext)
  888.      if (InRange(rp->base,block,rp->free)) break;
  889.  
  890.       if (rp == NULL)
  891.          for (rp = curblock->Gprev;rp;rp = rp->Gprev)
  892.             if (InRange(rp->base,block,rp->free)) break;
  893.  
  894.       /*
  895.        * If this block is not in a block region, its something else
  896.        *  like a procedure block.
  897.        */
  898.       if (rp == NULL)
  899.          return;
  900.  
  901.       /*
  902.        * Get this block's type field; return if it is marked
  903.        */
  904.       type = BlkType(block);
  905.       if ((uword)type > MaxType)
  906.          return;
  907.  
  908.       /*
  909.        * this is an unmarked block outside the (collecting) block region;
  910.        * process pointers and descriptors within the block.
  911.        *
  912.        * The type is valid, which indicates that this block has not
  913.        *  been marked.  Point endblock to the byte past the end
  914.        *  of the block.
  915.        */
  916.       endblock = block + BlkSize(block);
  917.  
  918.       BlkType(block) |= F_Mark;            /* mark the block */
  919.  
  920.       if ((fdesc = firstp[type]) > 0) {
  921.          /*
  922.           * The block contains pointers; mark each pointer.
  923.           */
  924.          ptr1 = (union block **)(block + fdesc);
  925.          numptr = ptrno[type];
  926.          if (numptr > 0)
  927.         lastptr = ptr1 + numptr;
  928.      else
  929.         lastptr = (union block **)endblock;
  930.      for (; ptr1 < lastptr; ptr1++)
  931.         if (*ptr1 != NULL)
  932.                markptr(ptr1);
  933.      }
  934.       if ((fdesc = firstd[type]) > 0)
  935.          /*
  936.           * The block contains descriptors; mark each descriptor.
  937.           */
  938.          for (dp = (dptr)(block + fdesc);
  939.               (char *)dp < endblock; dp++) {
  940.             if (Qual(*dp))
  941.                postqual(dp);
  942.             else if (Pointer(*dp))
  943.                markblock(dp);
  944.             }
  945.          }
  946.    }
  947.  
  948. /*
  949.  * sweep - sweep the chain of tended descriptors for a co-expression
  950.  *  marking the descriptors.
  951.  */
  952.  
  953. static novalue sweep(ce)
  954. struct b_coexpr *ce;
  955.    {
  956.    register struct tend_desc *tp;
  957.    register int i;
  958.  
  959.    for (tp = ce->es_tend; tp != NULL; tp = tp->previous) {
  960.       for (i = 0; i < tp->num; ++i) {
  961.          if (Qual(tp->d[i]))
  962.             postqual(&tp->d[i]);
  963.          else if (Pointer(tp->d[i])) {
  964.             if(BlkLoc(tp->d[i]) != NULL)
  965.                markblock(&tp->d[i]);
  966.         }
  967.          }
  968.       }
  969. #if !COMPILER
  970.    sweep_stk(ce);
  971. #endif                    /* !COMPILER */
  972.    }
  973.  
  974. #if !COMPILER
  975. /*
  976.  * sweep_stk - sweep the stack, marking all descriptors there.  Method
  977.  *  is to start at a known point, specifically, the frame that the
  978.  *  fp points to, and then trace back along the stack looking for
  979.  *  descriptors and local variables, marking them when they are found.
  980.  *  The sp starts at the first frame, and then is moved down through
  981.  *  the stack.  Procedure, generator, and expression frames are
  982.  *  recognized when the sp is a certain distance from the fp, gfp,
  983.  *  and efp respectively.
  984.  *
  985.  * Sweeping problems can be manifested in a variety of ways due to
  986.  *  the "if it can't be identified it's a descriptor" methodology.
  987.  */
  988.  
  989. static novalue sweep_stk(ce)
  990. struct b_coexpr *ce;
  991.    {
  992.    register word *s_sp;
  993.    register struct pf_marker *fp;
  994.    register struct gf_marker *s_gfp;
  995.    register struct ef_marker *s_efp;
  996.    word nargs, type, gsize;
  997.  
  998.    fp = ce->es_pfp;
  999.    s_gfp = ce->es_gfp;
  1000.    if (s_gfp != 0) {
  1001.       type = s_gfp->gf_gentype;
  1002.       if (type == G_Psusp)
  1003.          gsize = Wsizeof(*s_gfp);
  1004.       else
  1005.          gsize = Wsizeof(struct gf_smallmarker);
  1006.       }
  1007.    s_efp = ce->es_efp;
  1008.    s_sp =  ce->es_sp;
  1009.    nargs = 0;                           /* Nargs counter is 0 initially. */
  1010.  
  1011. #ifdef MultiThread
  1012.    if (fp == 0) {
  1013.       if (is:list(* (dptr) (s_sp - 1))) {
  1014.      /*
  1015.       * this is the argument list of an un-started task
  1016.       */
  1017.          if (Pointer(*((dptr)(&s_sp[-1])))) {
  1018.             markblock((dptr)&s_sp[-1]);
  1019.         }
  1020.      }
  1021.       }
  1022. #endif                    /* MultiThread */
  1023.  
  1024.    while ((fp != 0 || nargs)) {         /* Keep going until current fp is
  1025.                                             0 and no arguments are left. */
  1026.       if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) {
  1027.                                         /* sp has reached the upper
  1028.                                             boundary of a procedure frame,
  1029.                                             process the frame. */
  1030.          s_efp = fp->pf_efp;            /* Get saved efp out of frame */
  1031.          s_gfp = fp->pf_gfp;            /* Get save gfp */
  1032.          if (s_gfp != 0) {
  1033.             type = s_gfp->gf_gentype;
  1034.             if (type == G_Psusp)
  1035.                gsize = Wsizeof(*s_gfp);
  1036.             else
  1037.                gsize = Wsizeof(struct gf_smallmarker);
  1038.             }
  1039.          s_sp = (word *)fp - 1;         /* First argument descriptor is
  1040.                                             first word above proc frame */
  1041.          nargs = fp->pf_nargs;
  1042.          fp = fp->pf_pfp;
  1043.          }
  1044.       else if (s_gfp != NULL && s_sp == (word *)s_gfp + gsize - 1) {
  1045.                                         /* The sp has reached the lower end
  1046.                                             of a generator frame, process
  1047.                                             the frame.*/
  1048.          if (type == G_Psusp)
  1049.             fp = s_gfp->gf_pfp;
  1050.          s_sp = (word *)s_gfp - 1;
  1051.          s_efp = s_gfp->gf_efp;
  1052.          s_gfp = s_gfp->gf_gfp;
  1053.          if (s_gfp != 0) {
  1054.             type = s_gfp->gf_gentype;
  1055.             if (type == G_Psusp)
  1056.                gsize = Wsizeof(*s_gfp);
  1057.             else
  1058.                gsize = Wsizeof(struct gf_smallmarker);
  1059.             }
  1060.          nargs = 1;
  1061.          }
  1062.       else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) {
  1063.                                             /* The sp has reached the upper
  1064.                                                 end of an expression frame,
  1065.                                                 process the frame. */
  1066.          s_gfp = s_efp->ef_gfp;         /* Restore gfp, */
  1067.          if (s_gfp != 0) {
  1068.             type = s_gfp->gf_gentype;
  1069.             if (type == G_Psusp)
  1070.                gsize = Wsizeof(*s_gfp);
  1071.             else
  1072.                gsize = Wsizeof(struct gf_smallmarker);
  1073.             }
  1074.          s_efp = s_efp->ef_efp;         /*  and efp from frame. */
  1075.          s_sp -= Wsizeof(*s_efp);       /* Move past expression frame marker. */
  1076.          }
  1077.       else {                            /* Assume the sp is pointing at a
  1078.                                             descriptor. */
  1079.          if (Qual(*((dptr)(&s_sp[-1]))))
  1080.             postqual((dptr)&s_sp[-1]);
  1081.          else if (Pointer(*((dptr)(&s_sp[-1])))) {
  1082.             markblock((dptr)&s_sp[-1]);
  1083.         }
  1084.          s_sp -= 2;                     /* Move past descriptor. */
  1085.          if (nargs)                     /* Decrement argument count if in an*/
  1086.             nargs--;                    /*  argument list. */
  1087.          }
  1088.       }
  1089.    }
  1090. #endif                    /* !COMPILER */
  1091.  
  1092. /*
  1093.  * reclaim - reclaim space in the allocated memory regions. The marking
  1094.  *   phase has already been completed.
  1095.  */
  1096.  
  1097. static novalue reclaim()
  1098.    {
  1099.    /*
  1100.     * Collect available co-expression blocks.
  1101.     */
  1102.    cofree();
  1103.  
  1104.    /*
  1105.     * Collect the string space leaving it where it is.
  1106.     */
  1107.    if (!qualfail)
  1108.       scollect((word)0);
  1109.  
  1110.    /*
  1111.     * Adjust the blocks in the block region in place.
  1112.     */
  1113.    adjust(blkbase,blkbase);
  1114.  
  1115.    /*
  1116.     * Compact the block region.
  1117.     */
  1118.    compact(blkbase);
  1119.    }
  1120.  
  1121. /*
  1122.  * cofree - collect co-expression blocks.  This is done after
  1123.  *  the marking phase of garbage collection and the stacks that are
  1124.  *  reachable have pointers to data blocks, rather than T_Coexpr,
  1125.  *  in their type field.
  1126.  */
  1127.  
  1128. static novalue cofree()
  1129.    {
  1130.    register struct b_coexpr **ep, *xep;
  1131.    register struct astkblk *abp, *xabp;
  1132.  
  1133.    /*
  1134.     * Reset the type for &main.
  1135.     */
  1136.  
  1137. #ifdef MultiThread
  1138.    rootpstate.Mainhead->title = T_Coexpr;
  1139. #else                /* MultiThread */
  1140.    BlkLoc(k_main)->coexpr.title = T_Coexpr;
  1141. #endif                /* MultiThread */
  1142.  
  1143.    /*
  1144.     * The co-expression blocks are linked together through their
  1145.     *  nextstk fields, with stklist pointing to the head of the list.
  1146.     *  The list is traversed and each stack that was not marked
  1147.     *  is freed.
  1148.     */
  1149.    ep = &stklist;
  1150.    while (*ep != NULL) {
  1151.       if (BlkType(*ep) == T_Coexpr) {
  1152.          xep = *ep;
  1153.          *ep = (*ep)->nextstk;
  1154.          /*
  1155.           * Free the astkblks.  There should always be one and it seems that
  1156.           *  it's not possible to have more than one, but nonetheless, the
  1157.           *  code provides for more than one.
  1158.           */
  1159.          for (abp = xep->es_actstk; abp; ) {
  1160.             xabp = abp;
  1161.             abp = abp->astk_nxt;
  1162.             free((pointer)xabp);
  1163.             }
  1164.  
  1165. #ifdef CoProcesses
  1166.          coswitch(BlkLoc(k_current)->coexpr.cstate, xep->cstate, -1);
  1167.          /* terminate coproc for co-expression first */
  1168. #endif                    /* CoProcesses */
  1169.  
  1170.          free((pointer)xep);
  1171.          }
  1172.       else {
  1173.          BlkType(*ep) = T_Coexpr;
  1174.          ep = &(*ep)->nextstk;
  1175.          }
  1176.       }
  1177.    }
  1178.  
  1179. /*
  1180.  * scollect - collect the string space.  quallist is a list of pointers to
  1181.  *  descriptors for all the reachable strings in the string space.  For
  1182.  *  ease of description, it is referred to as if it were composed of
  1183.  *  descriptors rather than pointers to them.
  1184.  */
  1185.  
  1186. static novalue scollect(extra)
  1187. word extra;
  1188.    {
  1189.    register char *source, *dest;
  1190.    register dptr *qptr;
  1191.    char *cend;
  1192.  
  1193.    if (qualfree <= quallist) {
  1194.       /*
  1195.        * There are no accessible strings.  Thus, there are none to
  1196.        *  collect and the whole string space is free.
  1197.        */
  1198.       strfree = strbase;
  1199.       return;
  1200.       }
  1201.    /*
  1202.     * Sort the pointers on quallist in ascending order of string
  1203.     *  locations.
  1204.     */
  1205.    qsort((char *)quallist, (int)(DiffPtrs((char *)qualfree,(char *)quallist)) /
  1206.      sizeof(dptr *), sizeof(dptr), (int (*)())qlcmp);
  1207.    /*
  1208.     * The string qualifiers are now ordered by starting location.
  1209.     */
  1210.    dest = strbase;
  1211.    source = cend = StrLoc(**quallist);
  1212.  
  1213.    /*
  1214.     * Loop through qualifiers for accessible strings.
  1215.     */
  1216.    for (qptr = quallist; qptr < qualfree; qptr++) {
  1217.       if (StrLoc(**qptr) > cend) {
  1218.  
  1219.          /*
  1220.           * qptr points to a qualifier for a string in the next clump.
  1221.           *  The last clump is moved, and source and cend are set for
  1222.           *  the next clump.
  1223.           */
  1224.          while (source < cend)
  1225.             *dest++ = *source++;
  1226.          source = cend = StrLoc(**qptr);
  1227.          }
  1228.       if ((StrLoc(**qptr) + StrLen(**qptr)) > cend)
  1229.          /*
  1230.           * qptr is a qualifier for a string in this clump; extend
  1231.           *  the clump.
  1232.           */
  1233.          cend = StrLoc(**qptr) + StrLen(**qptr);
  1234.       /*
  1235.        * Relocate the string qualifier.
  1236.        */
  1237.       StrLoc(**qptr) = StrLoc(**qptr) + DiffPtrs(dest,source) + (uword)extra;
  1238.       }
  1239.  
  1240.    /*
  1241.     * Move the last clump.
  1242.     */
  1243.    while (source < cend)
  1244.       *dest++ = *source++;
  1245.    strfree = dest;
  1246.    }
  1247.  
  1248. /*
  1249.  * qlcmp - compare the location fields of two string qualifiers for qsort.
  1250.  */
  1251.  
  1252. static int qlcmp(q1,q2)
  1253. dptr *q1, *q2;
  1254.    {
  1255.  
  1256. #if IntBits == 16
  1257.    long l;
  1258.    l = (long)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));
  1259.    if (l < 0)
  1260.       return -1;
  1261.    else if (l > 0)
  1262.       return 1;
  1263.    else
  1264.       return 0;
  1265. #else                                   /* IntBits = 16 */
  1266.    return (int)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));
  1267. #endif                                  /* IntBits == 16 */
  1268.  
  1269.    }
  1270.  
  1271. /*
  1272.  * adjust - adjust pointers into the block region, beginning with block oblk
  1273.  *  and basing the "new" block region at nblk.  (Phase II of garbage
  1274.  *  collection.)
  1275.  */
  1276.  
  1277. static novalue adjust(source,dest)
  1278. char *source, *dest;
  1279.    {
  1280.    register union block **nxtptr, **tptr;
  1281.  
  1282.    /*
  1283.     * Loop through to the end of allocated block region, moving source
  1284.     *  to each block in turn and using the size of a block to find the
  1285.     *  next block.
  1286.     */
  1287.    while (source < blkfree) {
  1288.       if ((uword)(nxtptr = (union block **)BlkType(source)) > MaxType) {
  1289.  
  1290.          /*
  1291.           * The type field of source is a back pointer.  Traverse the
  1292.           *  chain of back pointers, changing each block location from
  1293.           *  source to dest.
  1294.           */
  1295.          while ((uword)nxtptr > MaxType) {
  1296.             tptr = nxtptr;
  1297.             nxtptr = (union block **) *nxtptr;
  1298.             *tptr = (union block *)dest;
  1299.             }
  1300.          BlkType(source) = (uword)nxtptr | F_Mark;
  1301.          dest += BlkSize(source);
  1302.          }
  1303.       source += BlkSize(source);
  1304.       }
  1305.    }
  1306.  
  1307. /*
  1308.  * compact - compact good blocks in the block region. (Phase III of garbage
  1309.  *  collection.)
  1310.  */
  1311.  
  1312. static novalue compact(source)
  1313. char *source;
  1314.    {
  1315.    register char *dest;
  1316.    register word size;
  1317.  
  1318.    /*
  1319.     * Start dest at source.
  1320.     */
  1321.    dest = source;
  1322.  
  1323.    /*
  1324.     * Loop through to end of allocated block space, moving source
  1325.     *  to each block in turn, using the size of a block to find the next
  1326.     *  block.  If a block has been marked, it is copied to the
  1327.     *  location pointed to by dest and dest is pointed past the end
  1328.     *  of the block, which is the location to place the next saved
  1329.     *  block.  Marks are removed from the saved blocks.
  1330.     */
  1331.    while (source < blkfree) {
  1332.       size = BlkSize(source);
  1333.       if (BlkType(source) & F_Mark) {
  1334.          BlkType(source) &= ~F_Mark;
  1335.          if (source != dest)
  1336.             mvc((uword)size,source,dest);
  1337.          dest += size;
  1338.          }
  1339.       source += size;
  1340.       }
  1341.  
  1342.    /*
  1343.     * dest is the location of the next free block.  Now that compaction
  1344.     *  is complete, point blkfree to that location.
  1345.     */
  1346.    blkfree = dest;
  1347.    }
  1348.  
  1349. /*
  1350.  * mvc - move n bytes from src to dest
  1351.  *
  1352.  *      The algorithm is to copy the data (using memcopy) in the largest
  1353.  * chunks possible, which is the size of area of the source data not in
  1354.  * the destination area (ie non-overlapped area).  (Chunks are expected to
  1355.  * be fairly large.)
  1356.  */
  1357.  
  1358. static novalue mvc(n, src, dest)
  1359. uword n;
  1360. register char *src, *dest;
  1361.    {
  1362.    register char *srcend, *destend;        /* end of data areas */
  1363.    word copy_size;                  /* of size copy_size */
  1364.    word left_over;         /* size of last chunk < copy_size */
  1365.  
  1366.    if (n == 0)
  1367.       return;
  1368.  
  1369.    srcend  = src + n;    /* point at byte after src data */
  1370.    destend = dest + n;   /* point at byte after dest area */
  1371.  
  1372.    if ((destend <= src) || (srcend <= dest))  /* not overlapping */
  1373.       memcopy(dest,src,n);
  1374.  
  1375.    else {                     /* overlapping data areas */
  1376.       if (dest < src) {
  1377.          /*
  1378.           * The move is from higher memory to lower memory.
  1379.           */
  1380.          copy_size = DiffPtrs(src,dest);
  1381.  
  1382.          /* now loop round copying copy_size chunks of data */
  1383.  
  1384.          do {
  1385.             memcopy(dest,src,copy_size);
  1386.             dest = src;
  1387.             src = src + copy_size;
  1388.             }
  1389.          while (DiffPtrs(srcend,src) > copy_size);
  1390.  
  1391.          left_over = DiffPtrs(srcend,src);
  1392.  
  1393.          /* copy final fragment of data - if there is one */
  1394.  
  1395.          if (left_over > 0)
  1396.             memcopy(dest,src,left_over);
  1397.          }
  1398.  
  1399.       else if (dest > src) {
  1400.          /*
  1401.           * The move is from lower memory to higher memory.
  1402.           */
  1403.          copy_size = DiffPtrs(destend,srcend);
  1404.  
  1405.          /* now loop round copying copy_size chunks of data */
  1406.  
  1407.          do {
  1408.             destend = srcend;
  1409.             srcend  = srcend - copy_size;
  1410.             memcopy(destend,srcend,copy_size);
  1411.             }
  1412.          while (DiffPtrs(srcend,src) > copy_size);
  1413.  
  1414.          left_over = DiffPtrs(srcend,src);
  1415.  
  1416.          /* copy intial fragment of data - if there is one */
  1417.  
  1418.          if (left_over > 0) memcopy(dest,src,left_over);
  1419.          }
  1420.  
  1421.       } /* end of overlapping data area code */
  1422.  
  1423.    /*
  1424.     *  Note that src == dest implies no action
  1425.     */
  1426.    }
  1427.  
  1428. #ifdef DeBugIconx
  1429. /*
  1430.  * descr - dump a descriptor.  Used only for debugging.
  1431.  */
  1432.  
  1433. novalue descr(dp)
  1434. dptr dp;
  1435.    {
  1436.    int i;
  1437.  
  1438.    fprintf(stderr,"%08lx: ",(long)dp);
  1439.    if (Qual(*dp))
  1440.       fprintf(stderr,"%15s","qualifier");
  1441.  
  1442.    else if (Var(*dp))
  1443.       fprintf(stderr,"%15s","variable");
  1444.    else {
  1445.       i =  Type(*dp);
  1446.       switch (i) {
  1447.          case T_Null:
  1448.             fprintf(stderr,"%15s","null");
  1449.             break;
  1450.          case T_Integer:
  1451.             fprintf(stderr,"%15s","integer");
  1452.             break;
  1453.          default:
  1454.             fprintf(stderr,"%15s",blkname[i]);
  1455.          }
  1456.       }
  1457.    fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp));
  1458.    }
  1459.  
  1460. /*
  1461.  * blkdump - dump the allocated block region.  Used only for debugging.
  1462.  *   NOTE:  Not adapted for multiple regions.
  1463.  */
  1464.  
  1465. novalue blkdump()
  1466.    {
  1467.    register char *blk;
  1468.    register word type, size, fdesc;
  1469.    register dptr ndesc;
  1470.  
  1471.    fprintf(stderr,
  1472.       "\nDump of allocated block region.  base:%08lx free:%08lx max:%08lx\n",
  1473.          (long)blkbase,(long)blkfree,(long)blkend);
  1474.    fprintf(stderr,"  loc     type              size  contents\n");
  1475.  
  1476.    for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) {
  1477.       type = BlkType(blk);
  1478.       size = BlkSize(blk);
  1479.       fprintf(stderr," %08lx   %15s   %4ld\n",(long)blk,blkname[type],
  1480.          (long)size);
  1481.       if ((fdesc = firstd[type]) > 0)
  1482.          for (ndesc = (dptr)(blk + fdesc);
  1483.                ndesc < (dptr)(blk + size); ndesc++) {
  1484.             fprintf(stderr,"                                 ");
  1485.             descr(ndesc);
  1486.             }
  1487.       fprintf(stderr,"\n");
  1488.       }
  1489.    fprintf(stderr,"end of block region.\n");
  1490.    }
  1491. #endif                                  /* DeBugIconx */
  1492.