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 / oasgn.r < prev    next >
Text File  |  2002-01-18  |  13KB  |  523 lines
  1. /*
  2.  * File: oasgn.r
  3.  */
  4.  
  5. /*
  6.  * Asgn - perform an assignment when the destination descriptor might
  7.  *  be within a block.
  8.  */
  9. #define Asgn(dest, src) *(dptr)((word *)VarLoc(dest) + Offset(dest)) = src;
  10.  
  11. /*
  12.  * GeneralAsgn - perform the assignment x := y, where x is known to be
  13.  *  a variable and y is has been dereferenced.
  14.  */
  15. #begdef GeneralAsgn(x, y)
  16.  
  17. #ifdef EventMon
  18.    body {
  19.       if (!is:null(curpstate->eventmask) &&
  20.          Testb((word)E_Assign, curpstate->eventmask)) {
  21.             EVAsgn(&x);
  22.         }
  23.       }
  24. #endif                    /* EventMon */
  25.  
  26.    type_case x of {
  27.       tvsubs: {
  28.         abstract {
  29.            store[store[type(x).str_var]] = string
  30.            }
  31.         inline {
  32.            if (subs_asgn(&x, (const dptr)&y) == Error)
  33.               runerr(0);
  34.            }
  35.         }
  36.       tvtbl: {
  37.         abstract {
  38.            store[store[type(x).trpd_tbl].tbl_val] = type(y)
  39.            }
  40.         inline {
  41.            if (tvtbl_asgn(&x, (const dptr)&y) == Error)
  42.               runerr(0);
  43.            }
  44.          }
  45.       kywdevent:
  46.      body {
  47.         *VarLoc(x) = y;
  48.         }
  49.       kywdwin:
  50.      body {
  51. #ifdef Graphics
  52.         if (is:null(y))
  53.            *VarLoc(x) = y;
  54.         else {
  55.            if ((!is:file(y)) || !(BlkLoc(y)->file.status & Fs_Window))
  56.           runerr(140,y);
  57.            *VarLoc(x) = y;
  58.            }
  59. #endif                    /* Graphics */
  60.         }
  61.       kywdint:
  62.      {
  63.          /*
  64.           * No side effect in the type realm - keyword x is still an int.
  65.           */
  66.          body {
  67.             C_integer i;
  68.  
  69.             if (!cnv:C_integer(y, i))
  70.                runerr(101, y);
  71.             IntVal(*VarLoc(x)) = i;
  72.  
  73. #ifdef Graphics
  74.         if (xyrowcol(&x) == -1)
  75.            runerr(140,kywd_xwin[XKey_Window]);
  76. #endif                    /* Graphics */
  77.         }
  78.     }
  79.       kywdpos: {
  80.          /*
  81.           * No side effect in the type realm - &pos is still an int.
  82.           */
  83.          body {
  84.             C_integer i;
  85.  
  86.             if (!cnv:C_integer(y, i))
  87.                runerr(101, y);
  88.  
  89. #ifdef MultiThread
  90.         i = cvpos((long)i, StrLen(*(VarLoc(x)+1)));
  91. #else                    /* MultiThread */
  92.             i = cvpos((long)i, StrLen(k_subject));
  93. #endif                    /* MultiThread */
  94.  
  95.             if (i == CvtFail)
  96.                fail;
  97.         IntVal(*VarLoc(x)) = i;
  98.  
  99.             EVVal(k_pos, E_Spos);
  100.             }
  101.          }
  102.       kywdsubj: {
  103.          /*
  104.           * No side effect in the type realm - &subject is still a string
  105.           *  and &pos is still an int.
  106.           */
  107.          if !cnv:string(y, *VarLoc(x)) then
  108.             runerr(103, y);
  109.          inline {
  110. #ifdef MultiThread
  111.         IntVal(*(VarLoc(x)-1)) = 1;
  112. #else                    /* MultiThread */
  113.             k_pos = 1;
  114. #endif                    /* MultiThread */
  115.             EVVal(k_pos, E_Spos);
  116.             }
  117.          }
  118.       kywdstr: {
  119.          /*
  120.           *  No side effect in the type realm.
  121.           */
  122.          if !cnv:string(y, *VarLoc(x)) then
  123.             runerr(103, y);
  124.          }
  125.       default: {
  126.          abstract {
  127.             store[type(x)] = type(y)
  128.             }
  129.          inline {
  130.             Asgn(x, y)
  131.             }
  132.          }
  133.       }
  134.  
  135. #ifdef EventMon
  136.    body {
  137.       EVValD(&y, E_Value);
  138.       }
  139. #endif                    /* EventMon */
  140.  
  141. #enddef
  142.  
  143.  
  144. "x := y - assign y to x."
  145.  
  146. operator{0,1} := asgn(underef x, y)
  147.  
  148.    if !is:variable(x) then
  149.       runerr(111, x)
  150.  
  151.    abstract {
  152.       return type(x)
  153.       }
  154.  
  155.    GeneralAsgn(x, y)
  156.  
  157.    inline {
  158.       /*
  159.        * The returned result is the variable to which assignment is being
  160.        *  made.
  161.        */
  162.       return x;
  163.       }
  164. end
  165.  
  166.  
  167. "x <- y - assign y to x."
  168. " Reverses assignment if resumed."
  169.  
  170. operator{0,1+} <- rasgn(underef x -> saved_x, y)
  171.  
  172.    if !is:variable(x) then
  173.       runerr(111, x)
  174.  
  175.    abstract {
  176.       return type(x)
  177.       }
  178.  
  179.    GeneralAsgn(x, y)
  180.  
  181.    inline {
  182.       suspend x;
  183.       }
  184.  
  185.    GeneralAsgn(x, saved_x)
  186.  
  187.    inline {
  188.       fail;
  189.       }
  190. end
  191.  
  192.  
  193. "x <-> y - swap values of x and y."
  194. " Reverses swap if resumed."
  195.  
  196. operator{0,1+} <-> rswap(underef x -> dx, underef y -> dy)
  197.  
  198.    declare {
  199.       tended union block *bp_x, *bp_y;
  200.       word adj1 = 0;
  201.       word adj2 = 0;
  202.       }
  203.  
  204.    if !is:variable(x) then
  205.       runerr(111, x)
  206.    if !is:variable(y) then
  207.       runerr(111, y)
  208.  
  209.    abstract {
  210.       return type(x)
  211.       }
  212.  
  213.    if is:tvsubs(x) && is:tvsubs(y) then
  214.       body {
  215.          bp_x = BlkLoc(x);
  216.          bp_y = BlkLoc(y);
  217.          if (VarLoc(bp_x->tvsubs.ssvar) == VarLoc(bp_y->tvsubs.ssvar) &&
  218.       Offset(bp_x->tvsubs.ssvar) == Offset(bp_y->tvsubs.ssvar)) {
  219.             /*
  220.              * x and y are both substrings of the same string, set
  221.              *  adj1 and adj2 for use in locating the substrings after
  222.              *  an assignment has been made.  If x is to the right of y,
  223.              *  set adj1 := *x - *y, otherwise if y is to the right of
  224.              *  x, set adj2 := *y - *x.  Note that the adjustment
  225.              *  values may be negative.
  226.              */
  227.             if (bp_x->tvsubs.sspos > bp_y->tvsubs.sspos)
  228.                adj1 = bp_x->tvsubs.sslen - bp_y->tvsubs.sslen;
  229.             else if (bp_y->tvsubs.sspos > bp_x->tvsubs.sspos)
  230.                adj2 = bp_y->tvsubs.sslen - bp_x->tvsubs.sslen;
  231.         }
  232.          }
  233.  
  234.    /*
  235.     * Do x := y
  236.     */
  237.    GeneralAsgn(x, dy)
  238.  
  239.    if is:tvsubs(x) && is:tvsubs(y) then
  240.       inline {
  241.          if (adj2 != 0)
  242.             /*
  243.              * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has
  244.              *  shifted the position of Arg2.  Add adj2 to the position of Arg2
  245.              *  to account for the replacement of Arg1 by Arg2.
  246.              */
  247.             bp_y->tvsubs.sspos += adj2;
  248.          }
  249.  
  250.    /*
  251.     * Do y := x
  252.     */
  253.    GeneralAsgn(y, dx)
  254.  
  255.    if is:tvsubs(x) && is:tvsubs(y) then
  256.       inline {
  257.          if (adj1 != 0)
  258.             /*
  259.              * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1
  260.              *  has shifted the position of Arg1.  Add adj2 to the position
  261.              *  of Arg1 to account for the replacement of Arg2 by Arg1.
  262.              */
  263.             bp_x->tvsubs.sspos += adj1;
  264.          }
  265.  
  266.    inline {
  267.       suspend x;
  268.       }
  269.    /*
  270.     * If resumed, the assignments are undone.  Note that the string position
  271.     *  adjustments are opposite those done earlier.
  272.     */
  273.    GeneralAsgn(x, dx)
  274.    if is:tvsubs(x) && is:tvsubs(y) then
  275.       inline {
  276.          if (adj2 != 0)
  277.            bp_y->tvsubs.sspos -= adj2;
  278.          }
  279.  
  280.    GeneralAsgn(y, dy)
  281.    if is:tvsubs(x) && is:tvsubs(y) then
  282.       inline {
  283.          if (adj1 != 0)
  284.             bp_x->tvsubs.sspos -= adj1;
  285.          }
  286.  
  287.    inline {
  288.       fail;
  289.       }
  290. end
  291.  
  292.  
  293. "x :=: y - swap values of x and y."
  294.  
  295. operator{0,1} :=: swap(underef x -> dx, underef y -> dy)
  296.    declare {
  297.       tended union block *bp_x, *bp_y;
  298.       word adj1 = 0;
  299.       word adj2 = 0;
  300.       }
  301.  
  302.    /*
  303.     * x and y must be variables.
  304.     */
  305.    if !is:variable(x) then
  306.       runerr(111, x)
  307.    if !is:variable(y) then
  308.       runerr(111, y)
  309.  
  310.    abstract {
  311.       return type(x)
  312.       }
  313.  
  314.    if is:tvsubs(x) && is:tvsubs(y) then
  315.       body {
  316.          bp_x = BlkLoc(x);
  317.          bp_y = BlkLoc(y);
  318.          if (VarLoc(bp_x->tvsubs.ssvar) == VarLoc(bp_y->tvsubs.ssvar) &&
  319.       Offset(bp_x->tvsubs.ssvar) == Offset(bp_y->tvsubs.ssvar)) {
  320.             /*
  321.              * x and y are both substrings of the same string, set
  322.              *  adj1 and adj2 for use in locating the substrings after
  323.              *  an assignment has been made.  If x is to the right of y,
  324.              *  set adj1 := *x - *y, otherwise if y is to the right of
  325.              *  x, set adj2 := *y - *x.  Note that the adjustment
  326.              *  values may be negative.
  327.              */
  328.             if (bp_x->tvsubs.sspos > bp_y->tvsubs.sspos)
  329.                adj1 = bp_x->tvsubs.sslen - bp_y->tvsubs.sslen;
  330.             else if (bp_y->tvsubs.sspos > bp_x->tvsubs.sspos)
  331.                adj2 = bp_y->tvsubs.sslen - bp_x->tvsubs.sslen;
  332.         }
  333.          }
  334.  
  335.    /*
  336.     * Do x := y
  337.     */
  338.    GeneralAsgn(x, dy)
  339.  
  340.    if is:tvsubs(x) && is:tvsubs(y) then
  341.       inline {
  342.          if (adj2 != 0)
  343.             /*
  344.              * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has
  345.              *  shifted the position of Arg2.  Add adj2 to the position of Arg2
  346.              *  to account for the replacement of Arg1 by Arg2.
  347.              */
  348.             bp_y->tvsubs.sspos += adj2;
  349.          }
  350.  
  351.    /*
  352.     * Do y := x
  353.     */
  354.    GeneralAsgn(y, dx)
  355.  
  356.    if is:tvsubs(x) && is:tvsubs(y) then
  357.       inline {
  358.          if (adj1 != 0)
  359.             /*
  360.              * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1
  361.              *  has shifted the position of Arg1.  Add adj2 to the position
  362.              *  of Arg1 to account for the replacement of Arg2 by Arg1.
  363.              */
  364.             bp_x->tvsubs.sspos += adj1;
  365.          }
  366.  
  367.    inline {
  368.       return x;
  369.       }
  370. end
  371.  
  372. /*
  373.  * subs_asgn - perform assignment to a substring. Leave the updated substring
  374.  *  in dest in case it is needed as the result of the assignment.
  375.  */
  376. int subs_asgn(dest, src)
  377. dptr dest;
  378. const dptr src;
  379.    {
  380.    tended struct descrip deststr;
  381.    tended struct descrip srcstr;
  382.    tended struct descrip rsltstr;
  383.    tended struct b_tvsubs *tvsub;
  384.  
  385.    char *s, *s2;
  386.    word i, len;
  387.    word prelen;   /* length of portion of string before substring */
  388.    word poststrt; /* start of portion of string following substring */
  389.    word postlen;  /* length of portion of string following substring */
  390.  
  391.    if (!cnv:tmp_string(*src, srcstr))
  392.       ReturnErrVal(103, *src, Error);
  393.  
  394.    /*
  395.     * Be sure that the variable in the trapped variable points
  396.     *  to a string and that the string is big enough to contain
  397.     *  the substring.
  398.     */
  399.    tvsub = (struct b_tvsubs *)BlkLoc(*dest);
  400.    deref(&tvsub->ssvar, &deststr);
  401.    if (!is:string(deststr))
  402.       ReturnErrVal(103, deststr, Error);
  403.    prelen = tvsub->sspos - 1;
  404.    poststrt = prelen + tvsub->sslen;
  405.    if (poststrt > StrLen(deststr))
  406.       ReturnErrNum(205, Error);
  407.  
  408.    /*
  409.     * Form the result string.
  410.     *  Start by allocating space for the entire result.
  411.     */
  412.    len = prelen + StrLen(srcstr) + StrLen(deststr) - poststrt;
  413.    Protect(s = alcstr(NULL, len), return Error);
  414.    StrLoc(rsltstr) = s;
  415.    StrLen(rsltstr) = len;
  416.    /*
  417.     * First, copy the portion of the substring string to the left of
  418.     *  the substring into the string space.
  419.     */
  420.    s2 = StrLoc(deststr);
  421.    for (i = 0; i < prelen; i++)
  422.       *s++ = *s2++;
  423.    /*
  424.     * Copy the string to be assigned into the string space,
  425.     *  effectively concatenating it.
  426.     */
  427.    s2 = StrLoc(srcstr);
  428.    for (i = 0; i < StrLen(srcstr); i++)
  429.       *s++ = *s2++;
  430.    /*
  431.     * Copy the portion of the substring to the right of
  432.     *  the substring into the string space, completing the
  433.     *  result.
  434.     */
  435.    s2 = StrLoc(deststr) + poststrt;
  436.    postlen = StrLen(deststr) - poststrt;
  437.    for (i = 0; i < postlen; i++)
  438.       *s++ = *s2++;
  439.  
  440.    /*
  441.     * Perform the assignment and update the trapped variable.
  442.     */
  443.    type_case tvsub->ssvar of {
  444.       kywdevent: {
  445.          *VarLoc(tvsub->ssvar) = rsltstr;
  446.          }
  447.       kywdstr: {
  448.          *VarLoc(tvsub->ssvar) = rsltstr;
  449.          }
  450.       kywdsubj: {
  451.          *VarLoc(tvsub->ssvar) = rsltstr;
  452.          k_pos = 1;
  453.          }
  454.       tvtbl: {
  455.          if (tvtbl_asgn(&tvsub->ssvar, (const dptr)&rsltstr) == Error)
  456.             return Error;
  457.          }
  458.       default: {
  459.          Asgn(tvsub->ssvar, rsltstr);
  460.          }
  461.       }
  462.    tvsub->sslen = StrLen(srcstr);
  463.  
  464.    EVVal(tvsub->sslen, E_Ssasgn);
  465.    return Succeeded;
  466.    }
  467.  
  468. /*
  469.  * tvtbl_asgn - perform an assignment to a table element trapped variable,
  470.  *  inserting the element in the table if needed.
  471.  */
  472. int tvtbl_asgn(dest, src)
  473. dptr dest;
  474. const dptr src;
  475.    {
  476.    tended struct b_tvtbl *bp;
  477.    tended struct descrip tval;
  478.    struct b_telem *te;
  479.    union block **slot;
  480.    struct b_table *tp;
  481.    int res;
  482.  
  483.    /*
  484.     * Allocate te now (even if we may not need it)
  485.     * because slot cannot be tended.
  486.     */
  487.    bp = (struct b_tvtbl *) BlkLoc(*dest);    /* Save params to tended vars */
  488.    tval = *src;
  489.    Protect(te = alctelem(), return Error);
  490.  
  491.    /*
  492.     * First see if reference is in the table; if it is, just update
  493.     *  the value.  Otherwise, allocate a new table entry.
  494.     */
  495.    slot = memb(bp->clink, &bp->tref, bp->hashnum, &res);
  496.  
  497.    if (res == 1) {
  498.       /*
  499.        * Do not need new te, just update existing entry.
  500.        */
  501.       deallocate((union block *) te);
  502.       (*slot)->telem.tval = tval;
  503.       }
  504.    else {
  505.       /*
  506.        * Link te into table, fill in entry.
  507.        */
  508.       tp = (struct b_table *) bp->clink;
  509.       tp->size++;
  510.  
  511.       te->clink = *slot;
  512.       *slot = (union block *) te;
  513.  
  514.       te->hashnum = bp->hashnum;
  515.       te->tref = bp->tref;
  516.       te->tval = tval;
  517.  
  518.       if (TooCrowded(tp))        /* grow hash table if now too full */
  519.          hgrow((union block *)tp);
  520.       }
  521.    return Succeeded;
  522.    }
  523.