home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Oref < prev    next >
Encoding:
Text File  |  1990-07-19  |  16.7 KB  |  598 lines
  1. /*
  2.  * File: oref.c
  3.  *  Contents: bang, random, sect, subsc
  4.  */
  5.  
  6. #include "../h/config.h"
  7. #include "../h/rt.h"
  8. #include "rproto.h"
  9.  
  10.  
  11. /*
  12.  * !x - generate successive values from object x.
  13.  */
  14.  
  15. OpDcl(bang,1,"!")
  16.    {
  17.    register word i, j, slen, rlen;
  18.    register union block *bp;
  19.    register dptr dp;
  20.    register char *sp;
  21.    int typ1;
  22.    char sbuf[MaxCvtLen];
  23.    FILE *fd;
  24.  
  25. #ifdef RecordIO
  26.    word status;
  27. #endif                    /* RecordIO */
  28.  
  29.    Arg2 = Arg1;
  30.  
  31.    if (DeRef(Arg1) == Error) 
  32.       RunErr(0, NULL);
  33.    if ((typ1 = cvstr(&Arg1, sbuf)) != CvtFail) {
  34.       /*
  35.        * A string is being banged.
  36.        */
  37.       i = 1;
  38.       while (i <= StrLen(Arg1)) {
  39.          /*
  40.           * Loop through the string using i as an index.
  41.           */
  42.          if (typ1 == Cvt) {
  43.             /*
  44.              * Arg1 was converted to a string, thus, the resulting string
  45.              *    cannot be modified and a trapped variable is not needed.
  46.              *    Make a one-character string out of the next character
  47.              *    in Arg1 and suspend it.
  48.              */
  49.             if (strreq((word)1) == Error) 
  50.                RunErr(0, NULL);
  51.             StrLen(Arg0) = 1;
  52.             StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, (word)1);
  53.             Suspend;
  54.             }
  55.          else {
  56.             /*
  57.              * Arg1 is a string and thus a trapped variable must be made
  58.              *    for the one character string being suspended.
  59.              */
  60.             if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  61.                RunErr(0, NULL);
  62.             mksubs(&Arg2, &Arg1, i, (word)1, &Arg0);
  63.             Suspend;
  64.             Arg1 = Arg2;
  65.             if (DeRef(Arg1) == Error) 
  66.                RunErr(0, NULL);
  67.             if (!Qual(Arg1)) 
  68.                RunErr(103, &Arg1);
  69.             }
  70.          i++;
  71.          }
  72.       }
  73.    else {
  74.       /*
  75.        * Arg1 is not a string.
  76.        */
  77.       switch (Type(Arg1)) {
  78.          case T_List:
  79.             /*
  80.              * Arg1 is a list.  Chain through each list element block and for
  81.              *    each one, suspend with a variable pointing to each
  82.              *    element contained in the block.
  83.              */
  84.             bp = BlkLoc(Arg1);
  85.             for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) {
  86.                for (i = 0; i < bp->lelem.nused; i++) {
  87.                   j = bp->lelem.first + i;
  88.                   if (j >= bp->lelem.nslots)
  89.                      j -= bp->lelem.nslots;
  90.                   dp = &bp->lelem.lslots[j];
  91.                   Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  92.                   VarLoc(Arg0) = (dptr)bp;
  93.           BlkLoc(Arg1) = bp;     /* save in Arg1 since bp is untended */
  94.                   Suspend;
  95.                   bp = BlkLoc(Arg1);     /* bp is untended, must reset */
  96.                   }
  97.                }
  98.             break;
  99.  
  100.  
  101.          case T_File:
  102.             /*
  103.              * Arg1 is a file.  Read the next line into the string space
  104.              *  and suspend the newly allocated string.
  105.              */
  106.             fd = BlkLoc(Arg1)->file.fd;
  107.  
  108. #ifdef RecordIO
  109.             status = BlkLoc(Arg1)->file.status;
  110. #endif                    /* RecordIO */
  111.  
  112.             if ((BlkLoc(Arg1)->file.status & Fs_Read) == 0)
  113.                RunErr(212, &Arg1);
  114.  
  115. #ifdef StandardLib
  116.             if (BlkLoc(Arg1)->file.status & Fs_Writing) {
  117.                fseek(fd, 0L, SEEK_CUR);
  118.                BlkLoc(Arg1)->file.status &= ~Fs_Writing;
  119.             }
  120.             BlkLoc(Arg1)->file.status |= Fs_Reading;
  121. #endif                    /* StandardLib */
  122.  
  123.             for (;;) {
  124.                StrLen(Arg0) = 0;
  125.                do {
  126.  
  127. #ifdef RecordIO
  128.                   if ((slen = (status & Fs_Record ?
  129.                                getrec(sbuf, MaxCvtLen, fd) :
  130.                                getstrg(sbuf, MaxCvtLen, fd))) == -1)
  131. #else                    /* RecordIO */
  132.                   if ((slen = getstrg(sbuf,MaxCvtLen,fd)) == -1)
  133. #endif                                  /* RecordIO */
  134.                      Fail;
  135.           rlen = slen < 0 ? (word)MaxCvtLen : slen;
  136.                   if (strreq(rlen) == Error) 
  137.                      RunErr(0, NULL);
  138.           sp = alcstr(sbuf,rlen);
  139.           if (StrLen(Arg0) == 0)
  140.                      StrLoc(Arg0) = sp;
  141.           StrLen(Arg0) += rlen;
  142.           } while (slen < 0);
  143.                   Suspend;
  144.                }
  145.             break;
  146.  
  147.          case T_Table:
  148.             /*
  149.              * Arg1 is a table.  Generate the element values.
  150.              */
  151.             MakeInt(2, &Arg2);        /* indicate that we want the values */
  152.             Forward(hgener);        /* go to the hash generator */
  153.  
  154.          case T_Set:
  155.             /*
  156.              * Arg1 is a set.  Generate the element values.
  157.              */
  158.             MakeInt(0, &Arg2);        /* indicate that we want set elements */
  159.             Forward(hgener);        /* go to the hash generator */
  160.  
  161.          case T_Record:
  162.             /*
  163.              * Arg1 is a record.  Loop through the fields and suspend
  164.              *    a variable pointing to each one.
  165.              */
  166.             bp = BlkLoc(Arg1);
  167.             j = bp->record.recdesc->proc.nfields;
  168.             for (i = 0; i < j; i++) {
  169.                dp = &bp->record.fields[i];
  170.                Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  171.                VarLoc(Arg0) = (dptr)bp;
  172.                Suspend;
  173.                bp = BlkLoc(Arg1);        /* bp is untended, must reset */
  174.                }
  175.             break;
  176.  
  177.          default: /* This object can not be compromised. */
  178.             RunErr(116, &Arg1);
  179.          }
  180.       }
  181.  
  182.    /*
  183.     * Eventually fail.
  184.     */
  185.    Fail;
  186.    }
  187.  
  188. #define RandVal (RanScale*(k_random=(RandA*(long)k_random+RandC)&0x7fffffffL))
  189.  
  190. /*
  191.  * ?x - produce a randomly selected element of x.
  192.  */
  193.  
  194. OpDcl(random,1,"?")
  195.    {
  196.    register word val, i, j, n;
  197.    register union block *bp, *ep;
  198.    struct b_slots *seg;
  199.    char sbuf[MaxCvtLen];
  200.    dptr dp;
  201.    double rval;
  202.  
  203.    Arg2 = Arg1;
  204.    if (DeRef(Arg1) == Error) 
  205.       RunErr(0, NULL);
  206.  
  207.    if (Qual(Arg1)) {
  208.       /*
  209.        * Arg1 is a string, produce a random character in it as the result.
  210.        *  Note that a substring trapped variable is returned.
  211.        */
  212.       if ((val = StrLen(Arg1)) <= 0)
  213.          Fail;
  214.       if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  215.          RunErr(0, NULL);
  216.       rval = RandVal;            /* This form is used to get around */
  217.       rval *= val;            /* a bug in a certain C compiler */
  218.       mksubs(&Arg2, &Arg1, (word)rval + 1, (word)1, &Arg0);
  219.       Return;
  220.       }
  221.  
  222.    switch (Type(Arg1)) {
  223.       case T_Cset:
  224.          /*
  225.           * Arg1 is a cset.  Convert it to a string, select a random character
  226.           *  of that string and return it.  Note that a substring trapped
  227.           *  variable is not needed.
  228.           */
  229.          cvstr(&Arg1, sbuf);
  230.          if ((val = StrLen(Arg1)) <= 0)
  231.             Fail;
  232.          if (strreq((word)1) == Error) 
  233.             RunErr(0, NULL);
  234.          StrLen(Arg0) = 1;
  235.          rval = RandVal;
  236.          rval *= val;
  237.          StrLoc(Arg0) = alcstr(StrLoc(Arg1)+(word)rval, (word)1);
  238.          Return;
  239.  
  240.  
  241.       case T_List:
  242.          /*
  243.           * Arg1 is a list.  Set i to a random number in the range [1,*Arg1],
  244.           *  failing if the list is empty.
  245.           */
  246.          bp = BlkLoc(Arg1);
  247.          val = bp->list.size;
  248.          if (val <= 0)
  249.             Fail;
  250.          rval = RandVal;
  251.          rval *= val;
  252.          i = (word)rval + 1;
  253.          j = 1;
  254.          /*
  255.           * Work down chain list of list blocks and find the block that
  256.           *  contains the selected element.
  257.           */
  258.          bp = bp->list.listhead;
  259.          while (i >= j + bp->lelem.nused) {
  260.             j += bp->lelem.nused;
  261.             bp = bp->lelem.listnext;
  262.             if (bp == NULL)
  263.                syserr("list reference out of bounds in random");
  264.             }
  265.          /*
  266.           * Locate the appropriate element and return a variable
  267.           * that points to it.
  268.           */
  269.          i += bp->lelem.first - j;
  270.          if (i >= bp->lelem.nslots)
  271.             i -= bp->lelem.nslots;
  272.          dp = &bp->lelem.lslots[i];
  273.          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  274.          VarLoc(Arg0) = (dptr)bp;
  275.          Return;
  276.  
  277.       case T_Table:
  278.       case T_Set:
  279.           /*
  280.            * Arg1 is a table or a set.  Set n to a random number in the range
  281.            *  [1,*Arg1], failing if the structure is empty.
  282.            */
  283.          bp = BlkLoc(Arg1);
  284.          val = bp->table.size;
  285.          if (val <= 0)
  286.             Fail;
  287.          rval = RandVal;
  288.          rval *= val;
  289.          n = (word)rval + 1;
  290.          /*
  291.           * Walk down the hash chains to find and return the n'th element.
  292.           */
  293.          for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++)
  294.             for (j = segsize[i] - 1; j >= 0; j--)
  295.                for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink)
  296.                   if (--n <= 0) {
  297.                      if (Type(Arg1) == T_Set) {
  298.                         /*
  299.                          * For a set, return the element value.
  300.                          */
  301.                         Arg0 = ep->selem.setmem;
  302.                         }
  303.                      else {
  304.                         /*
  305.                          * For a table, return a variable pointing to the
  306.                          *  selected element.
  307.                          */
  308.                         dp = &ep->telem.tval;
  309.                         Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  310.                         VarLoc(Arg0) = (dptr)bp;
  311.                         }
  312.                      Return;
  313.                      }
  314.  
  315.       case T_Record:
  316.          /*
  317.           * Arg1 is a record.  Set val to a random number in the range
  318.           *  [1,*Arg1] (*Arg1 is the number of fields), failing if the
  319.           *  record has no fields.
  320.           */
  321.          bp = BlkLoc(Arg1);
  322.          val = bp->record.recdesc->proc.nfields;
  323.          if (val <= 0)
  324.             Fail;
  325.          /*
  326.           * Locate the selected element and return a variable
  327.           * that points to it
  328.           */
  329.             rval = RandVal;
  330.             rval *= val;
  331.             dp = &bp->record.fields[(word)rval];
  332.             Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  333.             VarLoc(Arg0) = (dptr)bp;
  334.             Return;
  335.  
  336. #ifdef LargeInts
  337.       case T_Bignum:
  338.      if (bigrand(&Arg1, &Arg0) == Error)  /* alcbignum failed */
  339.         RunErr(0, NULL);
  340.      Return;
  341. #endif                    /* LargeInts */
  342.  
  343.       default:
  344.          /*
  345.           * Try converting it to an integer
  346.           */
  347.       switch (cvint(&Arg1)) {
  348.  
  349.          case T_Integer:
  350.             /*
  351.              * Arg1 is an integer, be sure that it's non-negative.
  352.              */
  353.             val = (word)IntVal(Arg1);
  354.             if (val < 0)
  355.                RunErr(205, &Arg1);
  356.  
  357.             /*
  358.              * val contains the integer value of Arg1.    If val is 0, return
  359.              *    a real in the range [0,1], else return an integer in the
  360.              *    range [1,val].
  361.              */
  362.             if (val == 0) {
  363.                rval = RandVal;
  364.                if (makereal(rval, &Arg0) == Error) 
  365.                   RunErr(0, NULL);
  366.                }
  367.             else {
  368.                rval = RandVal;
  369.                rval *= val;
  370.                MakeInt((long)rval + 1, &Arg0);
  371.                }
  372.             Return;
  373.  
  374.          default:
  375.             /*
  376.              * Arg1 is of a type for which random generation is not supported
  377.              */
  378.             RunErr(113, &Arg1);
  379.             }
  380.          }
  381.    }
  382.  
  383. /*
  384.  * x[i:j] - form a substring or list section of x.
  385.  */
  386.  
  387. OpDcl(sect,3,"[:]")
  388.    {
  389.    register word i, j, t;
  390.    int typ1;
  391.    char sbuf[MaxCvtLen];
  392.  
  393.    if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  394.       RunErr(0, NULL);
  395.  
  396.    if (cvint(&Arg2) == CvtFail) 
  397.       RunErr(101, &Arg2);
  398.    if (cvint(&Arg3) == CvtFail) 
  399.       RunErr(101, &Arg3);
  400.  
  401.    Arg4 = Arg1;
  402.    if (DeRef(Arg1) == Error) 
  403.       RunErr(0, NULL);
  404.  
  405.    if (Arg1.dword == D_List) {
  406.       i = cvpos(IntVal(Arg2), BlkLoc(Arg1)->list.size);
  407.       if (i == CvtFail)
  408.          Fail;
  409.       j = cvpos(IntVal(Arg3), BlkLoc(Arg1)->list.size);
  410.       if (j == CvtFail)
  411.          Fail;
  412.       if (i > j) {
  413.          t = i;
  414.          i = j;
  415.          j = t;
  416.          }
  417.       if (cplist(&Arg1, &Arg0, i, j) == Error) 
  418.          RunErr(0, NULL);
  419.       Return;
  420.       }
  421.  
  422.    if ((typ1 = cvstr(&Arg1, sbuf)) == CvtFail) 
  423.       RunErr(110, &Arg1);
  424.  
  425.    i = cvpos(IntVal(Arg2), StrLen(Arg1));
  426.    if (i == CvtFail)
  427.       Fail;
  428.    j = cvpos(IntVal(Arg3), StrLen(Arg1));
  429.    if (j == CvtFail)
  430.       Fail;
  431.    if (i > j) {             /* convert section to substring */
  432.       t = i;
  433.       i = j;
  434.       j = t - j;
  435.       }
  436.    else
  437.       j = j - i;
  438.  
  439.    if (typ1 == Cvt) {
  440.       /*
  441.        * A string was created - just return a string
  442.        */
  443.       if (strreq(j) == Error) 
  444.          RunErr(0, NULL);
  445.       StrLen(Arg0) = j;
  446.       StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, j);
  447.       }
  448.    else                 /* else make a substring tv */
  449.       mksubs(&Arg4, &Arg1, i, j, &Arg0);
  450.    Return;
  451.    }
  452.  
  453. /*
  454.  * x[y] - access yth character or element of x.
  455.  */
  456.  
  457. OpDcl(subsc,2,"[]")
  458.    {
  459.    register word i, j;
  460.    register union block *bp;
  461.    register uword hn;
  462.    int typ1, res;
  463.    dptr dp;
  464.    union block **dp1;
  465.    char sbuf[MaxCvtLen];
  466.  
  467.    /*
  468.     * Make a copy of Arg1.
  469.     */
  470.    Arg3 = Arg1;
  471.  
  472.    if (DeRef(Arg1) == Error) 
  473.       RunErr(0, NULL);
  474.    if ((typ1 = cvstr(&Arg1, sbuf)) != CvtFail) {
  475.       /*
  476.        * Arg1 is a string, make sure that Arg2 is an integer.
  477.        */
  478.       if (cvint(&Arg2) == CvtFail) 
  479.          RunErr(101, &Arg2);
  480.  
  481.       /*
  482.        * Convert Arg2 to a position in Arg1 and fail if the position is out
  483.        *  of bounds.
  484.        */
  485.       i = cvpos(IntVal(Arg2), StrLen(Arg1));
  486.       if (i == CvtFail || i > StrLen(Arg1))
  487.          Fail;
  488.       if (typ1 == Cvt) {
  489.          /*
  490.           * Arg1 was converted to a string, so it cannot be assigned back into.
  491.           *  Just return a string containing the selected character.
  492.           */
  493.          if (strreq((word)1) == Error) 
  494.             RunErr(0, NULL);
  495.          StrLen(Arg0) = 1;
  496.          StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, (word)1);
  497.          }
  498.       else {
  499.          /*
  500.           * Arg1 is a string, make a substring trapped variable for the one
  501.           *  character substring selected and return it.
  502.           */
  503.          if (blkreq((word)sizeof(struct b_tvsubs)) == Error) 
  504.             RunErr(0, NULL);
  505.          mksubs(&Arg3, &Arg1, i, (word)1, &Arg0);
  506.          }
  507.       Return;
  508.       }
  509.  
  510.    /*
  511.     * Arg1 is not a string or convertible to one, see if it's an aggregate.
  512.     */
  513.    switch (Type(Arg1)) {
  514.       case T_List:
  515.          /*
  516.           * Make sure that Arg2 is an integer and that the
  517.           *  subscript is in range.
  518.           */
  519.          if (cvint(&Arg2) == CvtFail) 
  520.             RunErr(101, &Arg2);
  521.          i = cvpos(IntVal(Arg2), BlkLoc(Arg1)->list.size);
  522.          if (i == CvtFail || i > BlkLoc(Arg1)->list.size)
  523.             Fail;
  524.  
  525.          /*
  526.           * Locate the list-element block containing the desired
  527.           *  element.
  528.           */
  529.          bp = BlkLoc(Arg1)->list.listhead;
  530.          j = 1;
  531.          while (bp != NULL && i >= j + bp->lelem.nused) {
  532.             j += bp->lelem.nused;
  533.             bp = bp->lelem.listnext;
  534.             }
  535.  
  536.          /*
  537.           * Locate the desired element and return a pointer to it.
  538.           */
  539.          i += bp->lelem.first - j;
  540.          if (i >= bp->lelem.nslots)
  541.             i -= bp->lelem.nslots;
  542.          dp = &bp->lelem.lslots[i];
  543.          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  544.          VarLoc(Arg0) = (dptr)bp;
  545.          Return;
  546.  
  547.       case T_Table:
  548.          /*
  549.           * Arg1 is a table.  Locate the appropriate bucket
  550.           *  based on the hash value.
  551.           */
  552.          if (blkreq((word)sizeof(struct b_tvtbl)) == Error) 
  553.             RunErr(0, NULL);
  554.          hn = hash(&Arg2);
  555.          dp1 = memb(BlkLoc(Arg1), &Arg2, hn, &res);
  556.          if (res == 1) {
  557.             bp = *dp1;
  558.             dp = &bp->telem.tval;
  559.             Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  560.             VarLoc(Arg0) = (dptr)bp;
  561.             }
  562.          else {
  563.             /*
  564.              * Arg1[Arg2] is not in the table, make a table element trapped
  565.              *  variable and return it as the result.
  566.              */
  567.             Arg0.dword = D_Tvtbl;
  568.             BlkLoc(Arg0) = (union block *)alctvtbl(&Arg1, &Arg2, hn);
  569.             }
  570.          Return;
  571.  
  572.       case T_Record:
  573.          /*
  574.           * Arg1 is a record.  Convert Arg2 to an integer and be sure that it
  575.           *  it is in range as a field number.
  576.           */
  577.          if (cvint(&Arg2) == CvtFail) 
  578.             RunErr(101, &Arg2);
  579.          bp = BlkLoc(Arg1);
  580.          i = cvpos(IntVal(Arg2), (word)(bp->record.recdesc->proc.nfields));
  581.          if (i == CvtFail || i > bp->record.recdesc->proc.nfields)
  582.             Fail;
  583.          /*
  584.           * Locate the appropriate field and return a pointer to it.
  585.           */
  586.          dp = &bp->record.fields[i-1];
  587.          Arg0.dword = D_Var + ((word *)dp - (word *)bp);
  588.          VarLoc(Arg0) = (dptr)bp;
  589.          Return;
  590.  
  591.       default:
  592.          /*
  593.           * Arg1 is of a type that cannot be subscripted.
  594.           */
  595.          RunErr(114, &Arg1);
  596.       }
  597.    }
  598.