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 / imisc.r < prev    next >
Text File  |  2002-01-18  |  8KB  |  358 lines
  1. #if !COMPILER
  2. /*
  3.  * File: imisc.r
  4.  *  Contents: field, mkrec, limit, llist, bscan, escan
  5.  */
  6.  
  7. /*
  8.  * x.y - access field y of record x.
  9.  */
  10.  
  11. LibDcl(field,2,".")
  12.    {
  13.    register word fnum;
  14.    register struct b_record *rp;
  15.    register dptr dp;
  16.  
  17. #ifdef MultiThread
  18.    register union block *bptr;
  19. #else                    /* MultiThread */
  20.    extern int *ftabp;
  21.    #ifdef FieldTableCompression
  22.       extern int *fo;
  23.       extern unsigned char *focp;
  24.       extern short *fosp;
  25.       extern char *bm;
  26.    #endif                /* FieldTableCompression */
  27.    extern word *records;
  28. #endif                    /* MultiThread */
  29.  
  30.    Deref(Arg1);
  31.  
  32.    /*
  33.     * Arg1 must be a record and Arg2 must be a field number.
  34.     */
  35.    if (!is:record(Arg1))
  36.       RunErr(107, &Arg1);
  37.    if (IntVal(Arg2) == -1)    /* if was known bad at ilink time */
  38.       RunErr(207, &Arg1);    /* was warning then, now it's fatal */
  39.  
  40.    /*
  41.     * Map the field number into a field number for the record x.
  42.     */
  43.    rp = (struct b_record *) BlkLoc(Arg1);
  44.  
  45. #ifdef MultiThread
  46.    bptr = rp->recdesc;
  47.    if (!InRange(curpstate->Records, bptr, curpstate->Ftabp)) {
  48.       int i;
  49.       int nfields = bptr->proc.nfields;
  50.       /*
  51.        * Look up the field number by a brute force search through
  52.        * the record constructor's field names.
  53.        */
  54.       Arg0 = fnames[IntVal(Arg2)];
  55.       fprintf(stderr,"looking up interprogram field %.*s\n", StrLen(Arg0),
  56.          StrLoc(Arg0));
  57.       for (i=0;i<nfields;i++){
  58.      if ((StrLen(Arg0) == StrLen(bptr->proc.lnames[i])) &&
  59.          !strncmp(StrLoc(Arg0), StrLoc(bptr->proc.lnames[i]),StrLen(Arg0)))
  60.        break;
  61.          }
  62.       if (i<nfields) fnum = i;
  63.       else fnum = -1;
  64.       }
  65.    else
  66. #endif                    /* MultiThread */
  67.  
  68. #ifdef FieldTableCompression
  69. #define FO(i) ((foffwidth==1)?focp[i]:((foffwidth==2)?fosp[i]:fo[i]))
  70. #define FTAB(i) ((ftabwidth==1)?ftabcp[i]:((ftabwidth==2)?ftabsp[i]:ftabp[i]))
  71. #else                    /* FieldTableCompression */
  72. #define FO(i) fo[i]
  73. #define FTAB(i) ftabp[i]
  74. #endif                    /* FieldTableCompression */
  75.  
  76. #ifdef FieldTableCompression
  77.       fnum = FTAB(FO(IntVal(Arg2)) + (rp->recdesc->proc.recnum - 1));
  78. #else                    /* FieldTableCompression */
  79.       fnum = FTAB(IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1);
  80. #endif                    /* FieldTableCompression */
  81.  
  82.    /*
  83.     * If fnum < 0, x doesn't contain the specified field.
  84.     */
  85.  
  86. #ifdef FieldTableCompression
  87. {
  88.    int bytes, index;
  89.    unsigned char this_bit = 0200;
  90.  
  91.    bytes = *records >> 3;
  92.    if ((*records & 07) != 0)
  93.       bytes++;
  94.    index = IntVal(Arg2) * bytes + (rp->recdesc->proc.recnum - 1) / 8;
  95.    this_bit = this_bit >> (rp->recdesc->proc.recnum - 1) % 8;
  96.    if ((bm[index] | this_bit) != bm[index])
  97.       RunErr(207, &Arg1);
  98. }
  99.  
  100.    if (ftabwidth == 1) {
  101.       if (fnum == 255)
  102.          RunErr(207, &Arg1);
  103.       }
  104.    else
  105. #endif                    /* FieldTableCompression */
  106.    if (fnum < 0)
  107.       RunErr(207, &Arg1);
  108.  
  109.    EVValD(&Arg1, E_Rref);
  110.    EVVal(fnum + 1, E_Rsub);
  111.  
  112.    /*
  113.     * Return a pointer to the descriptor for the appropriate field.
  114.     */
  115.    dp = &rp->fields[fnum];
  116.    Arg0.dword = D_Var + ((word *)dp - (word *)rp);
  117.    VarLoc(Arg0) = (dptr)rp;
  118.    Return;
  119.    }
  120.  
  121.  
  122. /*
  123.  * mkrec - create a record.
  124.  */
  125.  
  126. LibDcl(mkrec,-1,"mkrec")
  127.    {
  128.    register int i;
  129.    register struct b_proc *bp;
  130.    register struct b_record *rp;
  131.  
  132.    /*
  133.     * Be sure that call is from a procedure.
  134.     */
  135.  
  136.    /*
  137.     * Get a pointer to the record constructor procedure and allocate
  138.     *  a record with the appropriate number of fields.
  139.     */
  140.    bp = (struct b_proc *) BlkLoc(Arg0);
  141.    Protect(rp = alcrecd((int)bp->nfields, (union block *)bp), RunErr(0,NULL));
  142.  
  143.    /*
  144.     * Set all fields in the new record to null value.
  145.     */
  146.    for (i = (int)bp->nfields; i > nargs; i--)
  147.       rp->fields[i-1] = nulldesc;
  148.  
  149.    /*
  150.     * Assign each argument value to a record element and dereference it.
  151.     */
  152.    for ( ; i > 0; i--) {
  153.       rp->fields[i-1] = cargp[i]; /* Arg(i), expanded to avoid CLCC bug on Sun*/
  154.       Deref(rp->fields[i-1]);
  155.       }
  156.  
  157.    ArgType(0) = D_Record;
  158.    Arg0.vword.bptr = (union block *)rp;
  159.    EVValD(&Arg0, E_Rcreate);
  160.    Return;
  161.    }
  162.  
  163. /*
  164.  * limit - explicit limitation initialization.
  165.  */
  166.  
  167.  
  168. LibDcl(limit,2,"\\")
  169.    {
  170.  
  171.    C_integer tmp;
  172.  
  173.    /*
  174.     * The limit is both passed and returned in Arg0.  The limit must
  175.     *  be an integer.  If the limit is 0, the expression being evaluated
  176.     *  fails.  If the limit is < 0, it is an error.  Note that the
  177.     *  result produced by limit is ultimately picked up by the lsusp
  178.     *  function.
  179.     */
  180.    Deref(Arg0);
  181.  
  182.    if (!cnv:C_integer(Arg0,tmp))
  183.       RunErr(101, &Arg0);
  184.    MakeInt(tmp,&Arg0);
  185.  
  186.    if (IntVal(Arg0) < 0)
  187.       RunErr(205, &Arg0);
  188.    if (IntVal(Arg0) == 0)
  189.       Fail;
  190.    Return;
  191.    }
  192.  
  193. /*
  194.  * bscan - set &subject and &pos upon entry to a scanning expression.
  195.  *
  196.  *  Arguments are:
  197.  *    Arg0 - new value for &subject
  198.  *    Arg1 - saved value of &subject
  199.  *    Arg2 - saved value of &pos
  200.  *
  201.  * A variable pointing to the saved &subject and &pos is returned to be
  202.  *  used by escan.
  203.  */
  204.  
  205. LibDcl(bscan,2,"?")
  206.    {
  207.    int rc;
  208.    struct pf_marker *cur_pfp;
  209.  
  210.    /*
  211.     * Convert the new value for &subject to a string.
  212.     */
  213.    Deref(Arg0);
  214.  
  215.    if (!cnv:string(Arg0,Arg0))
  216.       RunErr(103, &Arg0);
  217.  
  218.    EVValD(&Arg0, E_Snew);
  219.  
  220.    /*
  221.     * Establish a new &subject value and set &pos to 1.
  222.     */
  223.    k_subject = Arg0;
  224.    k_pos = 1;
  225.  
  226.    /* If the saved scanning environment belongs to the current procedure
  227.     *  call, put a reference to it in the procedure frame.
  228.     */
  229.    if (pfp->pf_scan == NULL)
  230.       pfp->pf_scan = &Arg1;
  231.    cur_pfp = pfp;
  232.  
  233.    /*
  234.     * Suspend with a variable pointing to the saved &subject and &pos.
  235.     */
  236.    ArgType(0) = D_Var;
  237.    VarLoc(Arg0) = &Arg1;
  238.  
  239.    rc = interp(G_Csusp,cargp);
  240.  
  241. #ifdef EventMon
  242.    if (rc != A_Resume)
  243.       EVValD(&Arg1, E_Srem);
  244.    else
  245.       EVValD(&Arg1, E_Sfail);
  246. #endif                    /* EventMon */
  247.  
  248.    if (pfp != cur_pfp)
  249.       return rc;
  250.  
  251.    /*
  252.     * Leaving scanning environment. Restore the old &subject and &pos values.
  253.     */
  254.    k_subject = Arg1;
  255.    k_pos = IntVal(Arg2);
  256.  
  257.    if (pfp->pf_scan == &Arg1)
  258.       pfp->pf_scan = NULL;
  259.  
  260.    return rc;
  261.  
  262.    }
  263.  
  264. /*
  265.  * escan - restore &subject and &pos at the end of a scanning expression.
  266.  *
  267.  *  Arguments:
  268.  *    Arg0 - variable pointing to old values of &subject and &pos
  269.  *    Arg1 - result of the scanning expression
  270.  *
  271.  * The two arguments are reversed, so that the result of the scanning
  272.  *  expression becomes the result of escan. This result is dereferenced
  273.  *  if it refers to &subject or &pos. Then the saved values of &subject
  274.  *  and &pos are exchanged with the current ones.
  275.  *
  276.  * Escan suspends once it has restored the old &subject; on failure
  277.  *  the new &subject and &pos are "unrestored", and the failure is
  278.  *  propagated into the using clause.
  279.  */
  280.  
  281. LibDcl(escan,1,"escan")
  282.    {
  283.    struct descrip tmp;
  284.    int rc;
  285.    struct pf_marker *cur_pfp;
  286.  
  287.    /*
  288.     * Copy the result of the scanning expression into Arg0, which will
  289.     *  be the result of the scan.
  290.     */
  291.    tmp = Arg0;
  292.    Arg0 = Arg1;
  293.    Arg1 = tmp;
  294.  
  295.    /*
  296.     * If the result of the scanning expression is &subject or &pos,
  297.     *  it is dereferenced. #%#%  following is incorrect #%#%
  298.     */
  299.    /*if ((Arg0 == k_subject) ||
  300.       (Arg0 == kywd_pos))
  301.          Deref(Arg0); */
  302.  
  303.    /*
  304.     * Swap new and old values of &subject
  305.     */
  306.    tmp = k_subject;
  307.    k_subject = *VarLoc(Arg1);
  308.    *VarLoc(Arg1) = tmp;
  309.  
  310.    /*
  311.     * Swap new and old values of &pos
  312.     */
  313.    tmp = *(VarLoc(Arg1) + 1);
  314.    IntVal(*(VarLoc(Arg1) + 1)) = k_pos;
  315.    k_pos = IntVal(tmp);
  316.  
  317.    /*
  318.     * If we are returning to the scanning environment of the current
  319.     *  procedure call, indicate that it is no longed in a saved state.
  320.     */
  321.    if (pfp->pf_scan == VarLoc(Arg1))
  322.       pfp->pf_scan = NULL;
  323.    cur_pfp = pfp;
  324.  
  325.    /*
  326.     * Suspend with the value of the scanning expression.
  327.     */
  328.  
  329.    EVValD(&k_subject, E_Ssusp);
  330.  
  331.    rc = interp(G_Csusp,cargp);
  332.    if (pfp != cur_pfp)
  333.       return rc;
  334.  
  335.    /*
  336.     * Re-entering scanning environment, exchange the values of &subject
  337.     *  and &pos again
  338.     */
  339.    tmp = k_subject;
  340.    k_subject = *VarLoc(Arg1);
  341.    *VarLoc(Arg1) = tmp;
  342.  
  343. #ifdef EventMon
  344.    if (rc == A_Resume)
  345.       EVValD(&k_subject, E_Sresum);
  346. #endif                    /* EventMon */
  347.  
  348.    tmp = *(VarLoc(Arg1) + 1);
  349.    IntVal(*(VarLoc(Arg1) + 1)) = k_pos;
  350.    k_pos = IntVal(tmp);
  351.  
  352.    if (pfp->pf_scan == NULL)
  353.       pfp->pf_scan = VarLoc(Arg1);
  354.  
  355.    return rc;
  356.    }
  357. #endif                    /* !COMPILER */
  358.