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 / omisc.r < prev    next >
Text File  |  2001-12-12  |  6KB  |  285 lines
  1. /*
  2.  * File: omisc.r
  3.  *  Contents: refresh, size, tabmat, toby, to, llist
  4.  */
  5.  
  6. "^x - create a refreshed copy of a co-expression."
  7. #ifdef Coexpr
  8. /*
  9.  * ^x - return an entry block for co-expression x from the refresh block.
  10.  */
  11. operator{1} ^ refresh(x)
  12.    if !is:coexpr(x) then
  13.        runerr(118, x)
  14.    abstract {
  15.       return coexpr
  16.       }
  17.  
  18.    body {
  19.       register struct b_coexpr *sblkp;
  20.  
  21.       /*
  22.        * Get a new co-expression stack and initialize.
  23.        */
  24. #ifdef MultiThread
  25.       Protect(sblkp = alccoexp(0, 0), runerr(0));
  26. #else                    /* MultiThread */
  27.       Protect(sblkp = alccoexp(), runerr(0));
  28. #endif                    /* MultiThread */
  29.  
  30.       sblkp->freshblk = BlkLoc(x)->coexpr.freshblk;
  31.       if (ChkNull(sblkp->freshblk))    /* &main cannot be refreshed */
  32.          runerr(215, x);
  33.  
  34.       /*
  35.        * Use refresh block to finish initializing the new co-expression.
  36.        */
  37.       co_init(sblkp);
  38.  
  39. #if COMPILER
  40.       sblkp->fnc = BlkLoc(x)->coexpr.fnc;
  41.       if (line_info) {
  42.          if (debug_info)
  43.             PFDebug(sblkp->pf)->proc = PFDebug(BlkLoc(x)->coexpr.pf)->proc;
  44.          PFDebug(sblkp->pf)->old_fname =
  45.             PFDebug(BlkLoc(x)->coexpr.pf)->old_fname;
  46.          PFDebug(sblkp->pf)->old_line =
  47.             PFDebug(BlkLoc(x)->coexpr.pf)->old_line;
  48.          }
  49. #endif                    /* COMPILER */
  50.  
  51.       return coexpr(sblkp);
  52.       }
  53. #else                    /* Coexpr */
  54. operator{} ^ refresh(x)
  55.       runerr(401)
  56. #endif                    /* Coexpr */
  57.  
  58. end
  59.  
  60.  
  61. "*x - return size of string or object x."
  62.  
  63. operator{1} * size(x)
  64.    abstract {
  65.       return integer
  66.       }
  67.    type_case x of {
  68.       string: inline {
  69.          return C_integer StrLen(x);
  70.          }
  71.       list: inline {
  72.          return C_integer BlkLoc(x)->list.size;
  73.          }
  74.       table: inline {
  75.          return C_integer BlkLoc(x)->table.size;
  76.          }
  77.       set: inline {
  78.          return C_integer BlkLoc(x)->set.size;
  79.          }
  80.       cset: inline {
  81.          register word i;
  82.  
  83.          i = BlkLoc(x)->cset.size;
  84.      if (i < 0)
  85.         i = cssize(&x);
  86.          return C_integer i;
  87.          }
  88.       record: inline {
  89.          return C_integer BlkLoc(x)->record.recdesc->proc.nfields;
  90.          }
  91.       coexpr: inline {
  92.          return C_integer BlkLoc(x)->coexpr.size;
  93.          }
  94.       default: {
  95.          /*
  96.           * Try to convert it to a string.
  97.           */
  98.          if !cnv:tmp_string(x) then
  99.             runerr(112, x);    /* no notion of size */
  100.          inline {
  101.         return C_integer StrLen(x);
  102.             }
  103.          }
  104.       }
  105. end
  106.  
  107.  
  108. "=x - tab(match(x)).  Reverses effects if resumed."
  109.  
  110. operator{*} = tabmat(x)
  111.    /*
  112.     * x must be a string.
  113.     */
  114.    if !cnv:string(x) then
  115.       runerr(103, x)
  116.    abstract {
  117.       return string
  118.       }
  119.  
  120.    body {
  121.       register word l;
  122.       register char *s1, *s2;
  123.       C_integer i, j;
  124.       /*
  125.        * Make a copy of &pos.
  126.        */
  127.       i = k_pos;
  128.  
  129.       /*
  130.        * Fail if &subject[&pos:0] is not of sufficient length to contain x.
  131.        */
  132.       j = StrLen(k_subject) - i + 1;
  133.       if (j < StrLen(x))
  134.          fail;
  135.  
  136.       /*
  137.        * Get pointers to x (s1) and &subject (s2).  Compare them on a byte-wise
  138.        *  basis and fail if s1 doesn't match s2 for *s1 characters.
  139.        */
  140.       s1 = StrLoc(x);
  141.       s2 = StrLoc(k_subject) + i - 1;
  142.       l = StrLen(x);
  143.       while (l-- > 0) {
  144.          if (*s1++ != *s2++)
  145.             fail;
  146.          }
  147.  
  148.       /*
  149.        * Increment &pos to tab over the matched string and suspend the
  150.        *  matched string.
  151.        */
  152.       l = StrLen(x);
  153.       k_pos += l;
  154.  
  155.       EVVal(k_pos, E_Spos);
  156.  
  157.       suspend x;
  158.  
  159.       /*
  160.        * tabmat has been resumed, restore &pos and fail.
  161.        */
  162.       if (i > StrLen(k_subject) + 1)
  163.          runerr(205, kywd_pos);
  164.       else {
  165.          k_pos = i;
  166.          EVVal(k_pos, E_Spos);
  167.          }
  168.       fail;
  169.       }
  170. end
  171.  
  172.  
  173. "i to j by k - generate successive values."
  174.  
  175. operator{*} ... toby(from, to, by)
  176.    /*
  177.     * arguments must be integers.
  178.     */
  179.    if !cnv:C_integer(from) then
  180.       runerr(101, from)
  181.    if !cnv:C_integer(to) then
  182.       runerr(101, to)
  183.    if !cnv:C_integer(by) then
  184.       runerr(101, by)
  185.  
  186.    abstract {
  187.       return integer
  188.       }
  189.  
  190.    inline {
  191.       /*
  192.        * by must not be zero.
  193.        */
  194.       if (by == 0) {
  195.          irunerr(211, by);
  196.          errorfail;
  197.          }
  198.  
  199.       /*
  200.        * Count up or down (depending on relationship of from and to) and
  201.        *  suspend each value in sequence, failing when the limit has been
  202.        *  exceeded.
  203.        */
  204.       if (by > 0)
  205.          for ( ; from <= to; from += by) {
  206.             suspend C_integer from;
  207.             }
  208.       else
  209.          for ( ; from >= to; from += by) {
  210.             suspend C_integer from;
  211.             }
  212.       fail;
  213.       }
  214. end
  215.  
  216.  
  217. "i to j - generate successive values."
  218.  
  219. operator{*} ... to(from, to)
  220.    /*
  221.     * arguments must be integers.
  222.     */
  223.    if !cnv:C_integer(from) then
  224.       runerr(101, from)
  225.    if !cnv:C_integer(to) then
  226.       runerr(101, to)
  227.  
  228.    abstract {
  229.       return integer
  230.       }
  231.  
  232.    inline {
  233.       for ( ; from <= to; ++from) {
  234.          suspend C_integer from;
  235.          }
  236.       fail;
  237.       }
  238. end
  239.  
  240.  
  241. " [x1, x2, ... ] - create an explicitly specified list."
  242.  
  243. operator{1} [...] llist(elems[n])
  244.    abstract {
  245.       return new list(type(elems))
  246.       }
  247.    body {
  248.       tended struct b_list *hp;
  249.       register word i;
  250.       register struct b_lelem *bp;  /* need not be tended */
  251.       word nslots;
  252.  
  253.       nslots = n;
  254.       if (nslots == 0)
  255.          nslots = MinListSlots;
  256.  
  257.       /*
  258.        * Allocate the list and a list block.
  259.        */
  260.       Protect(hp = alclist(n), runerr(0));
  261.       Protect(bp = alclstb(nslots, (word)0, n), runerr(0));
  262.  
  263.       /*
  264.        * Make the list block just allocated into the first and last blocks
  265.        *  for the list.
  266.        */
  267.       hp->listhead = hp->listtail = (union block *)bp;
  268. #ifdef ListFix
  269.       bp->listprev = bp->listnext = (union block *)hp;
  270. #endif                    /* ListFix */
  271.  
  272.       /*
  273.        * Assign each argument to a list element.
  274.        */
  275.       for (i = 0; i < n; i++)
  276.          bp->lslots[i] = elems[i];
  277.  
  278. /*  Not quite right -- should be after list() returns in case it fails */
  279.       Desc_EVValD(hp, E_Lcreate, D_List);
  280.  
  281.       return list(hp);
  282.       }
  283. end
  284.  
  285.