home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / src / runtime / fstruct.r < prev    next >
Text File  |  2001-12-12  |  22KB  |  907 lines
  1. /*
  2.  * File: fstruct.r
  3.  *  Contents: delete, get, key, insert, list, member, pop, pull, push, put,
  4.  *  set, table
  5.  */
  6.  
  7. "delete(x1,x2) - delete element x2 from set or table x1 if it is there"
  8. " (always succeeds and returns x1)."
  9.  
  10. function{1} delete(s,x)
  11.    abstract {
  12.       return type(s) ** (set ++ table)
  13.       }
  14.  
  15.    /*
  16.     * The technique and philosophy here are the same
  17.     *  as used in insert - see comment there.
  18.     */
  19.    type_case s of {
  20.       set:
  21.          body {
  22.             register uword hn;
  23.             register union block **pd;
  24.             int res;
  25.  
  26.             hn = hash(&x);
  27.  
  28.             pd = memb(BlkLoc(s), &x, hn, &res);
  29.             if (res == 1) {
  30.                /*
  31.                * The element is there so delete it.
  32.                */
  33.                *pd = (*pd)->selem.clink;
  34.                (BlkLoc(s)->set.size)--;
  35.                }
  36.  
  37.             EVValD(&s, E_Sdelete);
  38.             EVValD(&x, E_Sval);
  39.             return s;
  40.         }
  41.       table:
  42.          body {
  43.             register union block **pd;
  44.             register uword hn;
  45.             int res;
  46.  
  47.             hn = hash(&x);
  48.             pd = memb(BlkLoc(s), &x, hn, &res);
  49.             if (res == 1) {
  50.                /*
  51.                 * The element is there so delete it.
  52.                 */
  53.                *pd = (*pd)->telem.clink;
  54.                (BlkLoc(s)->table.size)--;
  55.                }
  56.  
  57.             EVValD(&s, E_Tdelete);
  58.             EVValD(&x, E_Tsub);
  59.             return s;
  60.             }
  61.       default:
  62.          runerr(122, s)
  63.       }
  64. end
  65.  
  66.  
  67. /*
  68.  * c_get - convenient C-level access to the get function
  69.  *  returns 0 on failure, otherwise fills in res
  70.  */
  71. int c_get(hp, res)
  72. struct b_list *hp;
  73. struct descrip *res;
  74. {
  75.    register word i;
  76.    register struct b_lelem *bp;
  77.  
  78.    /*
  79.     * Fail if the list is empty.
  80.     */
  81.    if (hp->size <= 0)
  82.       return 0;
  83.  
  84.    /*
  85.     * Point bp at the first list block.  If the first block has no
  86.     *  elements in use, point bp at the next list block.
  87.     */
  88.    bp = (struct b_lelem *) hp->listhead;
  89.    if (bp->nused <= 0) {
  90.       bp = (struct b_lelem *) bp->listnext;
  91.       hp->listhead = (union block *) bp;
  92. #ifdef ListFix
  93.       bp->listprev = (union block *) hp;
  94. #else                    /* ListFix */
  95.       bp->listprev = NULL;
  96. #endif                    /* ListFix */
  97.       }
  98.  
  99.    /*
  100.     * Locate first element and assign it to result for return.
  101.     */
  102.    i = bp->first;
  103.    *res = bp->lslots[i];
  104.  
  105.    /*
  106.     * Set bp->first to new first element, or 0 if the block is now
  107.     *  empty.  Decrement the usage count for the block and the size
  108.     *  of the list.
  109.     */
  110.    if (++i >= bp->nslots)
  111.       i = 0;
  112.    bp->first = i;
  113.    bp->nused--;
  114.    hp->size--;
  115.  
  116.    return 1;
  117. }
  118.  
  119. #begdef GetOrPop(get_or_pop)
  120. #get_or_pop "(x) - " #get_or_pop " an element from the left end of list x."
  121. /*
  122.  * get(L) - get an element from end of list L.
  123.  *  Identical to pop(L).
  124.  */
  125. function{0,1} get_or_pop(x)
  126.    if !is:list(x) then
  127.       runerr(108, x)
  128.  
  129.    abstract {
  130.       return store[type(x).lst_elem]
  131.       }
  132.  
  133.    body {
  134.       EVValD(&x, E_Lget);
  135.       if (!c_get((struct b_list *)BlkLoc(x), &result)) fail;
  136.       return result;
  137.       }
  138. end
  139. #enddef
  140.  
  141. GetOrPop(get) /* get(x) - get an element from the left end of list x. */
  142. GetOrPop(pop) /* pop(x) - pop an element from the left end of list x. */
  143.  
  144.  
  145. "key(T) - generate successive keys (entry values) from table T."
  146.  
  147. function{*} key(t)
  148.    if !is:table(t) then
  149.          runerr(124, t)
  150.  
  151.    abstract {
  152.       return store[type(t).tbl_key]
  153.       }
  154.  
  155.    inline {
  156.       tended union block *ep;
  157.       struct hgstate state;
  158.  
  159.       EVValD(&t, E_Tkey);
  160.       for (ep = hgfirst(BlkLoc(t), &state); ep != 0;
  161.      ep = hgnext(BlkLoc(t), &state, ep)) {
  162.             EVValD(&ep->telem.tref, E_Tsub);
  163.             suspend ep->telem.tref;
  164.             }
  165.       fail;
  166.       }
  167. end
  168.  
  169.  
  170. "insert(x1, x2, x3) - insert element x2 into set or table x1 if not already there"
  171. " if x1 is a table, the assigned value for element x2 is x3."
  172. " (always succeeds and returns x1)."
  173.  
  174. function{1} insert(s, x, y)
  175.    type_case s of {
  176.  
  177.       set: {
  178.          abstract {
  179.             store[type(s).set_elem] = type(x)
  180.             return type(s)
  181.             }
  182.  
  183.          body {
  184.             tended union block *bp, *bp2;
  185.             register uword hn;
  186.             int res;
  187.             struct b_selem *se;
  188.             register union block **pd;
  189.  
  190.             bp = BlkLoc(s);
  191.             hn = hash(&x);
  192.             /*
  193.              * If x is a member of set s then res will have the value 1,
  194.              *  and pd will have a pointer to the pointer
  195.              *  that points to that member.
  196.              *  If x is not a member of the set then res will have
  197.              *  the value 0 and pd will point to the pointer
  198.              *  which should point to the member - thus we know where
  199.              *  to link in the new element without having to do any
  200.              *  repetitive looking.
  201.              */
  202.  
  203.         /* get this now because can't tend pd */
  204.             Protect(se = alcselem(&x, hn), runerr(0));
  205.  
  206.             pd = memb(bp, &x, hn, &res);
  207.             if (res == 0) {
  208.                /*
  209.                * The element is not in the set - insert it.
  210.                */
  211.                addmem((struct b_set *)bp, se, pd);
  212.                if (TooCrowded(bp))
  213.                   hgrow(bp);
  214.                }
  215.         else
  216.            deallocate((union block *)se);
  217.  
  218.             EVValD(&s, E_Sinsert);
  219.             EVValD(&x, E_Sval);
  220.             return s;
  221.             }
  222.          }
  223.  
  224.       table: {
  225.          abstract {
  226.             store[type(s).tbl_key] = type(x)
  227.             store[type(s).tbl_val] = type(y)
  228.             return type(s)
  229.             }
  230.  
  231.          body {
  232.             tended union block *bp, *bp2;
  233.             union block **pd;
  234.             struct b_telem *te;
  235.             register uword hn;
  236.             int res;
  237.  
  238.             bp = BlkLoc(s);
  239.             hn = hash(&x);
  240.  
  241.         /* get this now because can't tend pd */
  242.             Protect(te = alctelem(), runerr(0));
  243.  
  244.             pd = memb(bp, &x, hn, &res);    /* search table for key */
  245.             if (res == 0) {
  246.                /*
  247.                * The element is not in the table - insert it.
  248.                */
  249.                bp->table.size++;
  250.                te->clink = *pd;
  251.                *pd = (union block *)te;
  252.                te->hashnum = hn;
  253.                te->tref = x;
  254.                te->tval = y;
  255.                if (TooCrowded(bp))
  256.                   hgrow(bp);
  257.                }
  258.             else {
  259.            /*
  260.         * We found an existing entry; just change its value.
  261.         */
  262.            deallocate((union block *)te);
  263.                te = (struct b_telem *) *pd;
  264.                te->tval = y;
  265.                }
  266.  
  267.             EVValD(&s, E_Tinsert);
  268.             EVValD(&x, E_Tsub);
  269.             return s;
  270.             }
  271.          }
  272.  
  273.       default:
  274.          runerr(122, s);
  275.       }
  276. end
  277.  
  278.  
  279. "list(i, x) - create a list of size i, with initial value x."
  280.  
  281. function{1} list(n, x)
  282.    if !def:C_integer(n, 0L) then
  283.       runerr(101, n)
  284.  
  285.    abstract {
  286.       return new list(type(x))
  287.       }
  288.  
  289.    body {
  290.       tended struct b_list *hp;
  291.       register word i, size;
  292.       word nslots;
  293.       register struct b_lelem *bp; /* does not need to be tended */
  294.  
  295.       nslots = size = n;
  296.  
  297.       /*
  298.        * Ensure that the size is positive and that the list-element block
  299.        *  has at least MinListSlots slots.
  300.        */
  301.       if (size < 0) {
  302.          irunerr(205, n);
  303.          errorfail;
  304.          }
  305.       if (nslots == 0)
  306.          nslots = MinListSlots;
  307.  
  308.       /*
  309.        * Allocate the list-header block and a list-element block.
  310.        *  Note that nslots is the number of slots in the list-element
  311.        *  block while size is the number of elements in the list.
  312.        */
  313.       Protect(hp = alclist(size), runerr(0));
  314.       Protect(bp = alclstb(nslots, (word)0, size), runerr(0));
  315.       hp->listhead = hp->listtail = (union block *) bp;
  316. #ifdef ListFix
  317.       bp->listprev = bp->listnext = (union block *) hp;
  318. #endif                    /* ListFix */
  319.  
  320.       /*
  321.        * Initialize each slot.
  322.        */
  323.       for (i = 0; i < size; i++)
  324.          bp->lslots[i] = x;
  325.  
  326.       Desc_EVValD(hp, E_Lcreate, D_List);
  327.  
  328.       /*
  329.        * Return the new list.
  330.        */
  331.       return list(hp);
  332.       }
  333. end
  334.  
  335.  
  336. "member(x1, x2) - returns x1 if x2 is a member of set or table x2 but fails"
  337. " otherwise."
  338.  
  339. function{0,1} member(s, x)
  340.    type_case s of {
  341.  
  342.       set: {
  343.          abstract {
  344.             return type(x) ** store[type(s).set_elem]
  345.             }
  346.          inline {
  347.             int res;
  348.             register uword hn;
  349.  
  350.             EVValD(&s, E_Smember);
  351.             EVValD(&x, E_Sval);
  352.  
  353.             hn = hash(&x);
  354.             memb(BlkLoc(s), &x, hn, &res);
  355.             if (res==1)
  356.                return x;
  357.             else
  358.                fail;
  359.             }
  360.          }
  361.       table: {
  362.          abstract {
  363.             return type(x) ** store[type(s).tbl_key]
  364.             }
  365.          inline {
  366.             int res;
  367.             register uword hn;
  368.  
  369.             EVValD(&s, E_Tmember);
  370.             EVValD(&x, E_Tsub);
  371.  
  372.             hn = hash(&x);
  373.             memb(BlkLoc(s), &x, hn, &res);
  374.             if (res == 1)
  375.                return x;
  376.             else
  377.                fail;
  378.             }
  379.          }
  380.       default:
  381.          runerr(122, s)
  382.       }
  383. end
  384.  
  385.  
  386. "pull(L) - pull an element from end of list L."
  387.  
  388. function{0,1} pull(x)
  389.    /*
  390.     * x must be a list.
  391.     */
  392.    if !is:list(x) then
  393.       runerr(108, x)
  394.    abstract {
  395.       return store[type(x).lst_elem]
  396.       }
  397.  
  398.    body {
  399.       register word i;
  400.       register struct b_list *hp;
  401.       register struct b_lelem *bp;
  402.  
  403.       EVValD(&x, E_Lpull);
  404.  
  405.       /*
  406.        * Point at list header block and fail if the list is empty.
  407.        */
  408.       hp = (struct b_list *) BlkLoc(x);
  409.       if (hp->size <= 0)
  410.          fail;
  411.  
  412.       /*
  413.        * Point bp at the last list element block.  If the last block has no
  414.        *  elements in use, point bp at the previous list element block.
  415.        */
  416.       bp = (struct b_lelem *) hp->listtail;
  417.       if (bp->nused <= 0) {
  418.          bp = (struct b_lelem *) bp->listprev;
  419.          hp->listtail = (union block *) bp;
  420. #ifdef ListFix
  421.          bp->listnext = (union block *) hp;
  422. #else                    /* ListFix */
  423.          bp->listnext = NULL;
  424. #endif                    /* ListFix */
  425.          }
  426.  
  427.       /*
  428.        * Set i to position of last element and assign the element to
  429.        *  result for return.  Decrement the usage count for the block
  430.        *  and the size of the list.
  431.        */
  432.       i = bp->first + bp->nused - 1;
  433.       if (i >= bp->nslots)
  434.          i -= bp->nslots;
  435.       result = bp->lslots[i];
  436.       bp->nused--;
  437.       hp->size--;
  438.       return result;
  439.       }
  440. end
  441.  
  442. #ifdef Graphics
  443. /*
  444.  * c_push - C-level, nontending push operation
  445.  */
  446. void c_push(l, val)
  447. dptr l;
  448. dptr val;
  449. {
  450.    register word i;
  451.    register struct b_lelem *bp; /* does not need to be tended */
  452.    static int two = 2;        /* some compilers generate bad code for
  453.                    division by a constant that's a power of 2*/
  454.    /*
  455.     * Point bp at the first list-element block.
  456.     */
  457.    bp = (struct b_lelem *) BlkLoc(*l)->list.listhead;
  458.  
  459. #ifdef EventMon        /* initialize i so it's 0 if first list-element */
  460.    i = 0;            /* block isn't full */
  461. #endif                /* EventMon */
  462.  
  463.    /*
  464.     * If the first list-element block is full, allocate a new
  465.     *  list-element block, make it the first list-element block,
  466.     *  and make it the previous block of the former first list-element
  467.     *  block.
  468.     */
  469.    if (bp->nused >= bp->nslots) {
  470.       /*
  471.        * Set i to the size of block to allocate.
  472.        */
  473.       i = BlkLoc(*l)->list.size / two;
  474.       if (i < MinListSlots)
  475.          i = MinListSlots;
  476. #ifdef MaxListSlots
  477.       if (i > MaxListSlots)
  478.          i = MaxListSlots;
  479. #endif                    /* MaxListSlots */
  480.  
  481.       /*
  482.        * Allocate a new list element block.  If the block can't
  483.        *  be allocated, try smaller blocks.
  484.        */
  485.       while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  486.          i /= 4;
  487.          if (i < MinListSlots)
  488.             fatalerr(0, NULL);
  489.          }
  490.  
  491.       BlkLoc(*l)->list.listhead->lelem.listprev = (union block *) bp;
  492. #ifdef ListFix
  493.       bp->listprev = BlkLoc(*l);
  494. #endif                    /* ListFix */
  495.       bp->listnext = BlkLoc(*l)->list.listhead;
  496.       BlkLoc(*l)->list.listhead = (union block *) bp;
  497.       }
  498.  
  499.    /*
  500.     * Set i to position of new first element and assign val to
  501.     *  that element.
  502.     */
  503.    i = bp->first - 1;
  504.    if (i < 0)
  505.       i = bp->nslots - 1;
  506.    bp->lslots[i] = *val;
  507.    /*
  508.     * Adjust value of location of first element, block usage count,
  509.     *  and current list size.
  510.     */
  511.    bp->first = i;
  512.    bp->nused++;
  513.    BlkLoc(*l)->list.size++;
  514.    }
  515. #endif                    /* Graphics */
  516.  
  517.  
  518. "push(L, x1, ..., xN) - push x onto beginning of list L."
  519.  
  520. function{1} push(x, vals[n])
  521.    /*
  522.     * x must be a list.
  523.     */
  524.    if !is:list(x) then
  525.       runerr(108, x)
  526.    abstract {
  527.       store[type(x).lst_elem] = type(vals)
  528.       return type(x)
  529.       }
  530.  
  531.    body {
  532.       tended struct b_list *hp;
  533.       dptr dp;
  534.       register word i, val, num;
  535.       register struct b_lelem *bp; /* does not need to be tended */
  536.       static int two = 2;    /* some compilers generate bad code for
  537.                    division by a constant that's a power of 2*/
  538.  
  539.       if (n == 0) {
  540.      dp = &nulldesc;
  541.      num = 1;
  542.      }
  543.       else {
  544.      dp = vals;
  545.      num = n;
  546.      }
  547.  
  548.       for (val = 0; val < num; val++) {
  549.      /*
  550.       * Point hp at the list-header block and bp at the first
  551.       *  list-element block.
  552.       */
  553.      hp = (struct b_list *) BlkLoc(x);
  554.      bp = (struct b_lelem *) hp->listhead;
  555.  
  556. #ifdef EventMon        /* initialize i so it's 0 if first list-element */
  557.      i = 0;            /* block isn't full */
  558. #endif                /* EventMon */
  559.  
  560.      /*
  561.       * If the first list-element block is full, allocate a new
  562.       *  list-element block, make it the first list-element block,
  563.       *  and make it the previous block of the former first list-element
  564.       *  block.
  565.       */
  566.      if (bp->nused >= bp->nslots) {
  567.         /*
  568.          * Set i to the size of block to allocate.
  569.          */
  570.         i = hp->size / two;
  571.         if (i < MinListSlots)
  572.            i = MinListSlots;
  573. #ifdef MaxListSlots
  574.         if (i > MaxListSlots)
  575.            i = MaxListSlots;
  576. #endif                    /* MaxListSlots */
  577.  
  578.         /*
  579.          * Allocate a new list element block.  If the block can't
  580.          *  be allocated, try smaller blocks.
  581.          */
  582.         while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  583.            i /= 4;
  584.            if (i < MinListSlots)
  585.           runerr(0);
  586.            }
  587.  
  588.         hp->listhead->lelem.listprev = (union block *) bp;
  589. #ifdef ListFix
  590.         bp->listprev = (union block *) hp;
  591. #endif                    /* ListFix */
  592.         bp->listnext = hp->listhead;
  593.         hp->listhead = (union block *) bp;
  594.         }
  595.  
  596.      /*
  597.       * Set i to position of new first element and assign val to
  598.       *  that element.
  599.       */
  600.      i = bp->first - 1;
  601.      if (i < 0)
  602.         i = bp->nslots - 1;
  603.      bp->lslots[i] = dp[val];
  604.      /*
  605.       * Adjust value of location of first element, block usage count,
  606.       *  and current list size.
  607.       */
  608.      bp->first = i;
  609.      bp->nused++;
  610.      hp->size++;
  611.      }
  612.  
  613.       EVValD(&x, E_Lpush);
  614.  
  615.       /*
  616.        * Return the list.
  617.        */
  618.       return x;
  619.       }
  620. end
  621.  
  622. /*
  623.  * c_put - C-level, nontending list put function
  624.  */
  625. void c_put(l, val)
  626. struct descrip *l;
  627. struct descrip *val;
  628. {
  629.    register word i;
  630.    register struct b_lelem *bp;  /* does not need to be tended */
  631.    static int two = 2;        /* some compilers generate bad code for
  632.                    division by a constant that's a power of 2*/
  633.  
  634.    /*
  635.     * Point hp at the list-header block and bp at the last
  636.     *  list-element block.
  637.     */
  638.    bp = (struct b_lelem *) BlkLoc(*l)->list.listtail;
  639.  
  640. #ifdef EventMon        /* initialize i so it's 0 if last list-element */
  641.    i = 0;            /* block isn't full */
  642. #endif                /* EventMon */
  643.  
  644.    /*
  645.     * If the last list-element block is full, allocate a new
  646.     *  list-element block, make it the last list-element block,
  647.     *  and make it the next block of the former last list-element
  648.     *  block.
  649.     */
  650.    if (bp->nused >= bp->nslots) {
  651.       /*
  652.        * Set i to the size of block to allocate.
  653.        */
  654.       i = ((struct b_list *)BlkLoc(*l))->size / two;
  655.       if (i < MinListSlots)
  656.          i = MinListSlots;
  657. #ifdef MaxListSlots
  658.       if (i > MaxListSlots)
  659.          i = MaxListSlots;
  660. #endif                    /* MaxListSlots */
  661.  
  662.       /*
  663.        * Allocate a new list element block.  If the block can't
  664.        *  be allocated, try smaller blocks.
  665.        */
  666.       while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  667.          i /= 4;
  668.          if (i < MinListSlots)
  669.             fatalerr(0, NULL);
  670.          }
  671.  
  672.       ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext =
  673.     (union block *) bp;
  674.       bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail;
  675. #ifdef ListFix
  676.       bp->listnext = BlkLoc(*l);
  677. #endif                    /* ListFix */
  678.       ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp;
  679.       }
  680.  
  681.    /*
  682.     * Set i to position of new last element and assign val to
  683.     *  that element.
  684.     */
  685.    i = bp->first + bp->nused;
  686.    if (i >= bp->nslots)
  687.       i -= bp->nslots;
  688.    bp->lslots[i] = *val;
  689.  
  690.    /*
  691.     * Adjust block usage count and current list size.
  692.     */
  693.    bp->nused++;
  694.    ((struct b_list *)BlkLoc(*l))->size++;
  695. }
  696.  
  697.  
  698. "put(L, x1, ..., xN) - put elements onto end of list L."
  699.  
  700. function{1} put(x, vals[n])
  701.    /*
  702.     * x must be a list.
  703.     */
  704.    if !is:list(x) then
  705.       runerr(108, x)
  706.    abstract {
  707.       store[type(x).lst_elem] = type(vals)
  708.       return type(x)
  709.       }
  710.  
  711.    body {
  712.       tended struct b_list *hp;
  713.       dptr dp;
  714.       register word i, val, num;
  715.       register struct b_lelem *bp;  /* does not need to be tended */
  716.       static int two = 2;    /* some compilers generate bad code for
  717.                    division by a constant that's a power of 2*/
  718.       if (n == 0) {
  719.      dp = &nulldesc;
  720.      num = 1;
  721.      }
  722.       else {
  723.      dp = vals;
  724.      num = n;
  725.      }
  726.  
  727.       /*
  728.        * Point hp at the list-header block and bp at the last
  729.        *  list-element block.
  730.        */
  731.       for(val = 0; val < num; val++) {
  732.  
  733.      hp = (struct b_list *)BlkLoc(x);
  734.      bp = (struct b_lelem *) hp->listtail;
  735.  
  736. #ifdef EventMon        /* initialize i so it's 0 if last list-element */
  737.      i = 0;            /* block isn't full */
  738. #endif                /* EventMon */
  739.  
  740.      /*
  741.       * If the last list-element block is full, allocate a new
  742.       *  list-element block, make it the last list-element block,
  743.       *  and make it the next block of the former last list-element
  744.       *  block.
  745.       */
  746.      if (bp->nused >= bp->nslots) {
  747.         /*
  748.          * Set i to the size of block to allocate.
  749.          */
  750.         i = hp->size / two;
  751.         if (i < MinListSlots)
  752.            i = MinListSlots;
  753. #ifdef MaxListSlots
  754.         if (i > MaxListSlots)
  755.            i = MaxListSlots;
  756. #endif                    /* MaxListSlots */
  757.         /*
  758.          * Allocate a new list element block.  If the block can't
  759.          *  be allocated, try smaller blocks.
  760.          */
  761.         while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  762.            i /= 4;
  763.            if (i < MinListSlots)
  764.           runerr(0);
  765.            }
  766.  
  767.         hp->listtail->lelem.listnext = (union block *) bp;
  768.         bp->listprev = hp->listtail;
  769. #ifdef ListFix
  770.         bp->listnext = (union block *)hp;
  771. #endif                    /* ListFix */
  772.         hp->listtail = (union block *) bp;
  773.         }
  774.  
  775.      /*
  776.       * Set i to position of new last element and assign val to
  777.       *  that element.
  778.       */
  779.      i = bp->first + bp->nused;
  780.      if (i >= bp->nslots)
  781.         i -= bp->nslots;
  782.      bp->lslots[i] = dp[val];
  783.  
  784.      /*
  785.       * Adjust block usage count and current list size.
  786.       */
  787.      bp->nused++;
  788.      hp->size++;
  789.  
  790.      }
  791.  
  792.       EVValD(&x, E_Lput);
  793.  
  794.       /*
  795.        * Return the list.
  796.        */
  797.       return x;
  798.       }
  799. end
  800.  
  801.  
  802. "set(L) - create a set with members in list L."
  803. "  The members are linked into hash chains which are"
  804. " arranged in increasing order by hash number."
  805.  
  806. function{1} set(l)
  807.  
  808.    type_case l of {
  809.       null: {
  810.          abstract {
  811.             return new set(empty_type)
  812.             }
  813.          inline {
  814.             register union block * ps;
  815.             ps = hmake(T_Set, (word)0, (word)0);
  816.             if (ps == NULL)
  817.                runerr(0);
  818.             Desc_EVValD(ps, E_Screate, D_Set);
  819.             return set(ps);
  820.             }
  821.          }
  822.  
  823.       list: {
  824.          abstract {
  825.             return new set(store[type(l).lst_elem])
  826.             }
  827.  
  828.          body {
  829.             tended union block *pb;
  830.             register uword hn;
  831.             dptr pd;
  832.             struct b_selem *ne;      /* does not need to be tended */
  833.             int res;
  834.             word i, j;
  835.             tended union block *ps;
  836.             union block **pe;
  837.  
  838.             /*
  839.              * Make a set of the appropriate size.
  840.              */
  841.             pb = BlkLoc(l);
  842.             ps = hmake(T_Set, (word)0, pb->list.size);
  843.             if (ps == NULL)
  844.                runerr(0);
  845.  
  846.             /*
  847.              * Chain through each list block and for
  848.              *  each element contained in the block
  849.              *  insert the element into the set if not there.
  850.          *
  851.          * ne always has a new element ready for use.  We must get one
  852.          *  in advance, and stay one ahead, because pe can't be tended.
  853.          */
  854.         Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0));
  855.  
  856.             for (pb = pb->list.listhead;
  857. #ifdef ListFix
  858.          BlkType(pb) == T_Lelem;
  859. #else                    /* ListFix */
  860.          pb != NULL;
  861. #endif                    /* ListFix */
  862.          pb = pb->lelem.listnext) {
  863.                for (i = 0; i < pb->lelem.nused; i++) {
  864.                   j = pb->lelem.first + i;
  865.                   if (j >= pb->lelem.nslots)
  866.                      j -= pb->lelem.nslots;
  867.                   pd = &pb->lelem.lslots[j];
  868.                   pe = memb(ps, pd, hn = hash(pd), &res);
  869.                   if (res == 0) {
  870.              ne->setmem = *pd;            /* add new element */
  871.              ne->hashnum = hn;
  872.                      addmem((struct b_set *)ps, ne, pe);
  873.                             /* get another blk */
  874.                  Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0));
  875.                      }
  876.                   }
  877.                }
  878.         deallocate((union block *)ne);
  879.             Desc_EVValD(ps, E_Screate, D_Set);
  880.             return set(ps);
  881.             }
  882.          }
  883.  
  884.       default :
  885.          runerr(108, l)
  886.       }
  887. end
  888.  
  889.  
  890. "table(x) - create a table with default value x."
  891.  
  892. function{1} table(x)
  893.    abstract {
  894.       return new table(empty_type, empty_type, type(x))
  895.       }
  896.    inline {
  897.       union block *bp;
  898.  
  899.       bp = hmake(T_Table, (word)0, (word)0);
  900.       if (bp == NULL)
  901.          runerr(0);
  902.       bp->table.defvalue = x;
  903.       Desc_EVValD(bp, E_Tcreate, D_Table);
  904.       return table(bp);
  905.       }
  906. end
  907.