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 / oref.r < prev    next >
Text File  |  1996-03-22  |  23KB  |  858 lines
  1. /*
  2.  * File: oref.r
  3.  *  Contents: bang, random, sect, subsc
  4.  */
  5.  
  6. "!x - generate successive values from object x."
  7.  
  8. operator{*} ! bang(underef x -> dx)
  9.    declare {
  10.       register C_integer i, j;
  11.       tended union block *ep;
  12.       struct hgstate state;
  13.       char ch;
  14.       }
  15.  
  16.    if is:variable(x) && is:string(dx) then {
  17.       abstract {
  18.          return new tvsubs(type(x))
  19.          }
  20.       inline {
  21.          /*
  22.           * A nonconverted string from a variable is being banged.
  23.           *  Loop through the string suspending one-character substring
  24.           *  trapped variables.
  25.           */
  26.          for (i = 1; i <= StrLen(dx); i++) {
  27.             suspend tvsubs(&x, i, (word)1);
  28.             deref(&x, &dx);
  29.             if (!is:string(dx)) 
  30.                runerr(103, dx);
  31.             }
  32.          }
  33.       }
  34.    else type_case dx of {
  35.  
  36.       list: {
  37.          abstract {
  38.             return type(dx).lst_elem
  39.         }
  40.          inline {
  41.  
  42. #ifdef EventMon
  43.             word xi = 0;
  44.  
  45.             EVValD(&dx, E_Lbang);
  46. #endif                    /* EventMon */
  47.  
  48.             /*
  49.              * x is a list.  Chain through each list element block and for
  50.              * each one, suspend with a variable pointing to each
  51.              * element contained in the block.
  52.              */
  53.             for (ep = BlkLoc(dx)->list.listhead; ep != NULL;
  54.                  ep = ep->lelem.listnext){
  55.                for (i = 0; i < ep->lelem.nused; i++) {
  56.                   j = ep->lelem.first + i;
  57.                   if (j >= ep->lelem.nslots)
  58.                      j -= ep->lelem.nslots;
  59.  
  60. #ifdef EventMon
  61.                   MakeInt(++xi, &eventdesc);
  62.                   EVValD(&eventdesc, E_Lsub);
  63. #endif                    /* EventMon */
  64.  
  65.                   suspend struct_var(&ep->lelem.lslots[j], ep);
  66.                   }
  67.                }
  68.             }
  69.          }
  70.  
  71.       file: {
  72.          abstract {
  73.             return string
  74.            }
  75.          body {
  76.             FILE *fd;
  77.             char sbuf[MaxCvtLen];
  78.             register char *sp;
  79.             register C_integer slen, rlen;
  80.             word status;
  81.  
  82.             /*
  83.              * x is a file.  Read the next line into the string space
  84.              *    and suspend the newly allocated string.
  85.              */
  86.             fd = BlkLoc(dx)->file.fd;
  87.    
  88.             status = BlkLoc(dx)->file.status;
  89.             if ((status & Fs_Read) == 0) 
  90.                runerr(212, dx);
  91.  
  92. #ifdef StandardLib
  93.             if (status & Fs_Writing) {
  94.                fseek(fd, 0L, SEEK_CUR);
  95.                BlkLoc(dx)->file.status &= ~Fs_Writing;
  96.                }
  97.             BlkLoc(dx)->file.status |= Fs_Reading;
  98.             status = BlkLoc(dx)->file.status;
  99. #endif                    /* StandardLib */
  100.  
  101.             for (;;) {
  102.                StrLen(result) = 0;
  103.                do {
  104.  
  105. #ifdef Graphics
  106.                   pollctr >>= 1; pollctr++;
  107.                   if (status & Fs_Window) {
  108.                      slen = wgetstrg(sbuf,MaxCvtLen,fd);
  109.              if (slen == -1)
  110.             runerr(141);
  111.              else if (slen < -1)
  112.             runerr(143);
  113.                      }
  114.                   else
  115. #endif                    /* Graphics */
  116.  
  117. #ifdef RecordIO
  118.                   if ((slen = (status & Fs_Record ?
  119.                                getrec(sbuf, MaxCvtLen, fd) :
  120.                                getstrg(sbuf, MaxCvtLen, fd))) == -1)
  121. #else                    /* RecordIO */
  122.                   if ((slen = getstrg(sbuf,MaxCvtLen,fd)) == -1)
  123. #endif                                  /* RecordIO */
  124.  
  125.                      fail;
  126.                   rlen = slen < 0 ? (word)MaxCvtLen : slen;
  127.  
  128.           Protect(reserve(Strings, rlen), runerr(0));
  129.           if (!InRange(strbase,StrLoc(result),strfree)) {
  130.              Protect(reserve(Strings, StrLen(result)+rlen), runerr(0));
  131.              Protect((StrLoc(result) = alcstr(StrLoc(result),
  132.                         StrLen(result))), runerr(0));
  133.              }
  134.  
  135.                   Protect(sp = alcstr(sbuf,rlen), runerr(0));
  136.                   if (StrLen(result) == 0)
  137.                      StrLoc(result) = sp;
  138.                   StrLen(result) += rlen;
  139.                   } while (slen < 0);
  140.                suspend result;
  141.                }
  142.             }
  143.          }
  144.  
  145.       table: {
  146.          abstract {
  147.             return type(dx).tbl_val
  148.            }
  149.          inline {
  150.             struct b_tvtbl *tp;
  151.  
  152.             EVValD(&dx, E_Tbang);
  153.  
  154.             /*
  155.              * x is a table.  Chain down the element list in each bucket
  156.              * and suspend a variable pointing to each element in turn.
  157.              */
  158.         for (ep = hgfirst(BlkLoc(dx), &state); ep != 0;
  159.            ep = hgnext(BlkLoc(dx), &state, ep)) {
  160.  
  161.                   EVValD(&ep->telem.tval, E_Tval);
  162.  
  163.           Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0));
  164.           suspend tvtbl(tp);
  165.                   }
  166.             }
  167.          }
  168.  
  169.       set: {
  170.          abstract {
  171.             return store[type(dx).set_elem]
  172.             }
  173.          inline {
  174.             /*
  175.              *  This is similar to the method for tables except that a
  176.              *  value is returned instead of a variable.
  177.              */
  178.         for (ep = hgfirst(BlkLoc(dx), &state); ep != 0;
  179.            ep = hgnext(BlkLoc(dx), &state, ep)) {
  180.                   EVValD(&ep->selem.setmem, E_Sval);
  181.                   suspend ep->selem.setmem;
  182.                   }
  183.         }
  184.          }
  185.  
  186.       record: {
  187.          abstract {
  188.             return type(dx).all_fields
  189.            }
  190.          inline {
  191.             /*
  192.              * x is a record.  Loop through the fields and suspend
  193.              * a variable pointing to each one.
  194.              */
  195.  
  196. #ifdef EventMon
  197.             word xi = 0;
  198.  
  199.             EVValD(&dx, E_Rbang);
  200. #endif                    /* EventMon */
  201.  
  202.             j = BlkLoc(dx)->record.recdesc->proc.nfields;
  203.             for (i = 0; i < j; i++) {
  204.  
  205. #ifdef EventMon
  206.                   MakeInt(++xi, &eventdesc);
  207.                   EVValD(&eventdesc, E_Rsub);
  208. #endif                    /* EventMon */
  209.  
  210.                suspend struct_var(&BlkLoc(dx)->record.fields[i], 
  211.                   (struct b_record *)BlkLoc(dx));
  212.                }
  213.             }
  214.          }
  215.  
  216.       default:
  217.          if cnv:tmp_string(dx) then {
  218.             abstract {
  219.                return string
  220.                }
  221.             inline {
  222.                /*
  223.                 * A (converted or non-variable) string is being banged.
  224.                 * Loop through the string suspending simple one character
  225.                 *  substrings.
  226.                 */
  227.                for (i = 1; i <= StrLen(dx); i++) {
  228.                   ch = *(StrLoc(dx) + i - 1);
  229.                   suspend string(1, (char *)&allchars[FromAscii(ch) & 0xFF]);
  230.                   }
  231.                }
  232.             }
  233.          else
  234.             runerr(116, dx);
  235.       }
  236.  
  237.    inline {
  238.       fail;
  239.       }
  240. end      
  241.  
  242.  
  243. #define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&0x7FFFFFFFL))
  244.  
  245. "?x - produce a randomly selected element of x."
  246.  
  247. operator{0,1} ? random(underef x -> dx)
  248.  
  249. #ifndef LargeInts
  250.    declare {
  251.       C_integer v = 0;
  252.       }
  253. #endif                    /* LargeInts */
  254.  
  255.    if is:variable(x) && is:string(dx) then {
  256.       abstract {
  257.          return new tvsubs(type(x))
  258.          }
  259.       body {
  260.          C_integer val;
  261.          double rval;
  262.  
  263.          /*
  264.           * A string from a variable is being banged. Produce a one
  265.           *  character substring trapped variable.
  266.           */
  267.          if ((val = StrLen(dx)) <= 0)
  268.             fail;
  269.          rval = RandVal;    /* This form is used to get around */
  270.          rval *= val;        /* a bug in a certain C compiler */
  271.          return tvsubs(&x, (word)rval + 1, (word)1);
  272.          }
  273.       }
  274.    else type_case dx of {
  275.       string: {
  276.          /*
  277.           * x is a string, but it is not a variable. Produce a
  278.           *   random character in it as the result; a substring
  279.           *   trapped variable is not needed.
  280.           */
  281.          abstract {
  282.             return string
  283.             }
  284.          body {
  285.             C_integer val;
  286.             double rval;
  287.  
  288.             if ((val = StrLen(dx)) <= 0)
  289.                fail;
  290.             rval = RandVal;
  291.             rval *= val;
  292.             return string(1, StrLoc(dx)+(word)rval);
  293.             }
  294.          }
  295.  
  296.       cset: {
  297.          /*
  298.           * x is a cset.  Convert it to a string, select a random character
  299.           *  of that string and return it. A substring trapped variable is
  300.           *  not needed.
  301.           */
  302.          if !cnv:tmp_string(dx) then
  303.             { /* cannot fail */ }
  304.          abstract {
  305.             return string
  306.             }
  307.          body {
  308.             C_integer val;
  309.             double rval;
  310.         char ch;
  311.  
  312.             if ((val = StrLen(dx)) <= 0)
  313.                fail;
  314.             rval = RandVal;
  315.             rval *= val;
  316.             ch = *(StrLoc(dx) + (word)rval);
  317.             return string(1, (char *)&allchars[FromAscii(ch) & 0xFF]);
  318.             }
  319.          }
  320.  
  321.       list: {
  322.          abstract {
  323.             return type(dx).lst_elem
  324.             }
  325.          /*
  326.           * x is a list.  Set i to a random number in the range [1,*x],
  327.           *  failing if the list is empty.
  328.           */
  329.          body {
  330.             C_integer val;
  331.             double rval;
  332.             register C_integer i, j;
  333.             union block *bp;     /* doesn't need to be tended */
  334.             val = BlkLoc(dx)->list.size;
  335.             if (val <= 0)
  336.                fail;
  337.             rval = RandVal;
  338.             rval *= val;
  339.             i = (word)rval + 1;
  340.  
  341. #ifdef EventMon
  342.             EVValD(&dx, E_Lrand);
  343.             MakeInt(i, &eventdesc);
  344.             EVValD(&eventdesc, E_Lsub);
  345. #endif                    /* EventMon */
  346.  
  347.             j = 1;
  348.             /*
  349.              * Work down chain list of list blocks and find the block that
  350.              *  contains the selected element.
  351.              */
  352.             bp = BlkLoc(dx)->list.listhead;
  353.             while (i >= j + bp->lelem.nused) {
  354.                j += bp->lelem.nused;
  355.                bp = bp->lelem.listnext;
  356.                if (bp == NULL)
  357.                   syserr("list reference out of bounds in random");
  358.                }
  359.             /*
  360.              * Locate the appropriate element and return a variable
  361.              * that points to it.
  362.              */
  363.             i += bp->lelem.first - j;
  364.             if (i >= bp->lelem.nslots)
  365.                i -= bp->lelem.nslots;
  366.             return struct_var(&bp->lelem.lslots[i], bp);
  367.             }
  368.          }
  369.  
  370.       table: {
  371.          abstract {
  372.             return type(dx).tbl_val
  373.             }
  374.           /*
  375.            * x is a table.  Set n to a random number in the range [1,*x],
  376.            *  failing if the table is empty.
  377.            */
  378.          body {
  379.             C_integer val;
  380.             double rval;
  381.             register C_integer i, j, n;
  382.             union block *ep, *bp;   /* doesn't need to be tended */
  383.         struct b_slots *seg;
  384.         struct b_tvtbl *tp;
  385.  
  386.             bp = BlkLoc(dx);
  387.             val = bp->table.size;
  388.             if (val <= 0)
  389.                fail;
  390.             rval = RandVal;
  391.             rval *= val;
  392.             n = (word)rval + 1;
  393.  
  394. #ifdef EventMon
  395.             EVValD(&dx, E_Trand);
  396.             MakeInt(n, &eventdesc);
  397.             EVValD(&eventdesc, E_Tsub);
  398. #endif                    /* EventMon */
  399.  
  400.  
  401.             /*
  402.              * Walk down the hash chains to find and return the nth element
  403.          *  as a variable.
  404.              */
  405.             for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  406.                for (j = segsize[i] - 1; j >= 0; j--)
  407.                   for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  408.                      if (--n <= 0)
  409.             {
  410.             Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0));
  411.             return tvtbl(tp);
  412.             }
  413.             syserr("table reference out of bounds in random");
  414.             }
  415.          }
  416.  
  417.       set: {
  418.          abstract {
  419.             return store[type(dx).set_elem]
  420.             }
  421.          /*
  422.           * x is a set.  Set n to a random number in the range [1,*x],
  423.           *  failing if the set is empty.
  424.           */
  425.          body {
  426.             C_integer val;
  427.             double rval;
  428.             register C_integer i, j, n;
  429.             union block *bp, *ep;  /* doesn't need to be tended */
  430.         struct b_slots *seg;
  431.  
  432.             bp = BlkLoc(dx);
  433.             val = bp->set.size;
  434.             if (val <= 0)
  435.                fail;
  436.             rval = RandVal;
  437.             rval *= val;
  438.             n = (word)rval + 1;
  439.  
  440. #ifdef EventMon
  441.             EVValD(&dx, E_Srand);
  442.             MakeInt(n, &eventdesc);
  443. #endif                    /* EventMon */
  444.  
  445.             /*
  446.              * Walk down the hash chains to find and return the nth element.
  447.              */
  448.             for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  449.                for (j = segsize[i] - 1; j >= 0; j--)
  450.                   for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  451.                      if (--n <= 0)
  452.                         return ep->selem.setmem;
  453.             syserr("set reference out of bounds in random");
  454.             }
  455.          }
  456.  
  457.       record: {
  458.          abstract {
  459.             return type(dx).all_fields
  460.             }
  461.          /*
  462.           * x is a record.  Set val to a random number in the range
  463.           *  [1,*x] (*x is the number of fields), failing if the
  464.           *  record has no fields.
  465.           */
  466.          body {
  467.             C_integer val;
  468.             double rval;
  469.             struct b_record *rec;  /* doesn't need to be tended */
  470.  
  471.             rec = (struct b_record *)BlkLoc(dx);
  472.             val = rec->recdesc->proc.nfields;
  473.             if (val <= 0)
  474.                fail;
  475.             /*
  476.              * Locate the selected element and return a variable
  477.              * that points to it
  478.              */
  479.             rval = RandVal;
  480.             rval *= val;
  481.  
  482. #ifdef EventMon
  483.             EVValD(&dx, E_Rrand);
  484.             MakeInt(rval + 1, &eventdesc);
  485.             EVValD(&eventdesc, E_Rsub);
  486. #endif                    /* EventMon */
  487.  
  488.             return struct_var(&rec->fields[(word)rval], rec);
  489.             }
  490.          }
  491.  
  492.       default: {
  493.  
  494. #ifdef LargeInts
  495.          if !cnv:integer(dx) then
  496.             runerr(113, dx)
  497. #else                    /* LargeInts */
  498.          if !cnv:C_integer(dx,v) then
  499.             runerr(113, dx)
  500. #endif                    /* LargeInts */
  501.  
  502.          abstract {
  503.             return integer ++ real
  504.             }
  505.          body {
  506.             double rval;
  507.  
  508. #ifdef LargeInts
  509.             C_integer v;
  510.             if (Type(dx) == T_Lrgint) {
  511.            if (bigrand(&dx, &result) == Error)  /* alcbignum failed */
  512.               runerr(0);
  513.            return result;
  514.            }
  515.  
  516.             v = IntVal(dx);
  517. #endif                    /* LargeInts */
  518.             /*
  519.              * x is an integer, be sure that it's non-negative.
  520.              */
  521.             if (v < 0) 
  522.                runerr(205, dx);
  523.  
  524.             /*
  525.              * val contains the integer value of x. If val is 0, return
  526.              *    a real in the range [0,1), else return an integer in the
  527.              *    range [1,val].
  528.              */
  529.             if (v == 0) {
  530.                rval = RandVal;
  531.                return C_double rval;
  532.                }
  533.             else {
  534.                rval = RandVal;
  535.                rval *= v;
  536.                return C_integer (long)rval + 1;
  537.                }
  538.             }
  539.          }
  540.       }
  541. end
  542.  
  543. "x[i:j] - form a substring or list section of x."
  544.  
  545. operator{0,1} [:] sect(underef x -> dx, i, j)
  546.    declare {
  547.       int use_trap = 0;
  548.       }
  549.  
  550.    if is:list(dx) then {
  551.       abstract {
  552.          return type(dx)
  553.          }
  554.       /*
  555.        * If it isn't a C integer, but is a large integer, fail on
  556.        * the out-of-range index.
  557.        */
  558.       if !cnv:C_integer(i) then {
  559.      if cnv : integer(i) then inline { fail; }
  560.      runerr(101, i)
  561.      }
  562.       if !cnv:C_integer(j) then {
  563.          if cnv : integer(j) then inline { fail; }
  564.      runerr(101, j)
  565.          }
  566.  
  567.       body {
  568.          C_integer t;
  569.  
  570.          i = cvpos((long)i, (long)BlkLoc(dx)->list.size);
  571.          if (i == CvtFail)
  572.             fail;
  573.          j = cvpos((long)j, (long)BlkLoc(dx)->list.size);
  574.          if (j == CvtFail)
  575.             fail;
  576.          if (i > j) {
  577.             t = i;
  578.             i = j;
  579.             j = t;
  580.             }
  581.          if (cplist(&dx, &result, i, j) == Error)
  582.         runerr(0);
  583.          return result;
  584.          }
  585.       }
  586.    else {
  587.  
  588.       /*
  589.        * x should be a string. If x is a variable, we must create a
  590.        *  substring trapped variable.
  591.        */
  592.       if is:variable(x) && is:string(dx) then {
  593.          abstract {
  594.             return new tvsubs(type(x))
  595.             }
  596.          inline {
  597.             use_trap = 1;
  598.             }
  599.          }
  600.       else if cnv:string(dx) then
  601.          abstract {
  602.             return string
  603.             }
  604.       else
  605.          runerr(110, dx)
  606.  
  607.       /*
  608.        * If it isn't a C integer, but is a large integer, fail on
  609.        * the out-of-range index.
  610.        */
  611.       if !cnv:C_integer(i) then {
  612.      if cnv : integer(i) then inline { fail; }
  613.      runerr(101, i)
  614.      }
  615.       if !cnv:C_integer(j) then {
  616.          if cnv : integer(j) then inline { fail; }
  617.      runerr(101, j)
  618.          }
  619.  
  620.       body {
  621.          C_integer t;
  622.  
  623.          i = cvpos((long)i, (long)StrLen(dx));
  624.          if (i == CvtFail)
  625.             fail;
  626.          j = cvpos((long)j, (long)StrLen(dx));
  627.          if (j == CvtFail)
  628.             fail;
  629.          if (i > j) {             /* convert section to substring */
  630.             t = i;
  631.             i = j;
  632.             j = t - j;
  633.             }
  634.          else
  635.             j = j - i;
  636.    
  637.          if (use_trap) {
  638.             return tvsubs(&x, i, j);
  639.             }
  640.          else
  641.             return string(j, StrLoc(dx)+i-1);
  642.          }
  643.       }
  644. end
  645.  
  646. "x[y] - access yth character or element of x."
  647.  
  648. operator{0,1} [] subsc(underef x -> dx,y)
  649.    declare {
  650.       int use_trap = 0;
  651.       }
  652.  
  653.    type_case dx of {
  654.       list: {
  655.          abstract {
  656.             return type(dx).lst_elem
  657.             }
  658.          /*
  659.           * Make sure that y is a C integer.
  660.           */
  661.          if !cnv:C_integer(y) then {
  662.         /*
  663.          * If it isn't a C integer, but is a large integer, fail on
  664.          * the out-of-range index.
  665.          */
  666.         if cnv : integer(y) then inline { fail; }
  667.         runerr(101, y)
  668.         }
  669.          body {
  670.             word i, j;
  671.             register union block *bp; /* doesn't need to be tended */
  672.             struct b_list *lp;        /* doesn't need to be tended */
  673.  
  674. #ifdef EventMon
  675.             EVValD(&dx, E_Lref);
  676.             MakeInt(y, &eventdesc);
  677.             EVValD(&eventdesc, E_Lsub);
  678. #endif                    /* EventMon */
  679.  
  680.         /*
  681.          * Make sure that subscript y is in range.
  682.          */
  683.             lp = (struct b_list *)BlkLoc(dx);
  684.             i = cvpos((long)y, (long)lp->size);
  685.             if (i == CvtFail || i > lp->size)
  686.                fail;
  687.             /*
  688.              * Locate the list-element block containing the desired
  689.              *  element.
  690.              */
  691.             bp = lp->listhead;
  692.             j = 1;
  693.             while (bp != NULL && i >= j + bp->lelem.nused) {
  694.                j += bp->lelem.nused;
  695.                bp = bp->lelem.listnext;
  696.                }
  697.  
  698.             /*
  699.              * Locate the desired element and return a pointer to it.
  700.              */
  701.             i += bp->lelem.first - j;
  702.             if (i >= bp->lelem.nslots)
  703.                i -= bp->lelem.nslots;
  704.             return struct_var(&bp->lelem.lslots[i], bp);
  705.             }
  706.          }
  707.  
  708.       table: {
  709.          abstract {
  710.             store[type(dx).tbl_key] = type(y) /* the key might be added */
  711.             return type(dx).tbl_val ++ new tvtbl(type(dx))
  712.             }
  713.          /*
  714.           * x is a table.  Return a table element trapped variable
  715.       *  representing the result; defer actual lookup until later.
  716.           */
  717.          body {
  718.             uword hn;
  719.         struct b_tvtbl *tp;
  720.  
  721.             EVValD(&dx, E_Tref);
  722.             EVValD(&y, E_Tsub);
  723.  
  724.         hn = hash(&y);
  725.             Protect(tp = alctvtbl(&dx, &y, hn), runerr(0));
  726.             return tvtbl(tp);
  727.             }
  728.          }
  729.  
  730.       record: {
  731.          abstract {
  732.             return type(dx).all_fields
  733.             }
  734.          /*
  735.           * x is a record.  Convert y to an integer and be sure that it
  736.           *  it is in range as a field number.
  737.           */
  738.      if !cnv:C_integer(y) then body {
  739.         if (!cnv:tmp_string(y,y))
  740.            runerr(101,y);
  741.         else {
  742.            register union block *bp;  /* doesn't need to be tended */
  743.            register union block *bp2; /* doesn't need to be tended */
  744.            register word i;
  745.            register int len;
  746.            char *loc;
  747.            int nf;
  748.            bp = BlkLoc(dx);
  749.            bp2 = BlkLoc(dx)->record.recdesc;
  750.            nf = bp2->proc.nfields;
  751.            loc = StrLoc(y);
  752.            len = StrLen(y);
  753.            for(i=0; i<nf; i++) {
  754.           if (len == StrLen(bp2->proc.lnames[i]) &&
  755.               !strncmp(loc, StrLoc(bp2->proc.lnames[i]), len)) {
  756.  
  757. #ifdef EventMon
  758.              EVValD(&dx, E_Rref);
  759.              MakeInt(i+1, &eventdesc);
  760.              EVValD(&eventdesc, E_Rsub);
  761. #endif                    /* EventMon */
  762.  
  763.              /*
  764.               * Found the field, return a pointer to it.
  765.               */
  766.              return struct_var(&bp->record.fields[i], bp);
  767.              }
  768.           }
  769.            fail;
  770.                }
  771.         }
  772.      else
  773.          body {
  774.             word i;
  775.             register union block *bp; /* doesn't need to be tended */
  776.  
  777.             bp = BlkLoc(dx);
  778.             i = cvpos(y, (word)(bp->record.recdesc->proc.nfields));
  779.             if (i == CvtFail || i > bp->record.recdesc->proc.nfields)
  780.                fail;
  781.  
  782. #ifdef EventMon
  783.             EVValD(&dx, E_Rref);
  784.             MakeInt(i, &eventdesc);
  785.             EVValD(&eventdesc, E_Rsub);
  786. #endif                    /* EventMon */
  787.  
  788.             /*
  789.              * Locate the appropriate field and return a pointer to it.
  790.              */
  791.             return struct_var(&bp->record.fields[i-1], bp);
  792.             }
  793.          }
  794.  
  795.       default: {
  796.          /*
  797.           * dx must either be a string or be convertible to one. Decide
  798.           *  whether a substring trapped variable can be created.
  799.           */
  800.          if is:variable(x) && is:string(dx) then {
  801.             abstract {
  802.                return new tvsubs(type(x))
  803.                }
  804.             inline {
  805.                use_trap = 1;
  806.                }
  807.             }
  808.          else if cnv:tmp_string(dx) then
  809.             abstract {
  810.                return string
  811.                }
  812.          else
  813.             runerr(114, dx)
  814.  
  815.          /*
  816.           * Make sure that y is a C integer.
  817.           */
  818.          if !cnv:C_integer(y) then {
  819.         /*
  820.          * If it isn't a C integer, but is a large integer, fail on
  821.          * the out-of-range index.
  822.          */
  823.         if cnv : integer(y) then inline { fail; }
  824.         runerr(101, y)
  825.         }
  826.  
  827.          body {
  828.             char ch;
  829.             word i;
  830.  
  831.             /*
  832.              * Convert y to a position in x and fail if the position
  833.              *  is out of bounds.
  834.              */
  835.             i = cvpos(y, StrLen(dx));
  836.             if (i == CvtFail || i > StrLen(dx))
  837.                fail;
  838.             if (use_trap) {
  839.                /*
  840.                 * x is a string, make a substring trapped variable for the
  841.                 * one character substring selected and return it.
  842.                 */
  843.                return tvsubs(&x, i, (word)1);
  844.                }
  845.             else {
  846.                /*
  847.                 * x was converted to a string, so it cannot be assigned
  848.                 * back into. Just return a string containing the selected
  849.                 * character.
  850.                 */
  851.                ch = *(StrLoc(dx)+i-1);
  852.                return string(1, (char *)&allchars[FromAscii(ch) & 0xFF]);
  853.                }
  854.             }
  855.          }
  856.       }
  857. end
  858.