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