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