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