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 / invoke.r < prev    next >
Text File  |  1996-03-22  |  9KB  |  384 lines
  1. /*
  2.  * invoke.r - contains invoke, apply
  3.  */
  4.  
  5. #if COMPILER
  6.  
  7. /*
  8.  * invoke - perform general invocation on a value.
  9.  */
  10. int invoke(nargs, args, rslt, succ_cont)
  11. int nargs;
  12. dptr args;
  13. dptr rslt;
  14. continuation succ_cont;
  15.    {
  16.    tended struct descrip callee;
  17.    struct b_proc *proc;
  18.    C_integer n;
  19.  
  20.    /*
  21.     * remove the operation being called from the argument list.
  22.     */
  23.    deref(&args[0], &callee);
  24.    ++args;
  25.    nargs -= 1;
  26.  
  27.    if (is:proc(callee))
  28.       return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt,
  29.          succ_cont);
  30.    else if (cnv:C_integer(callee, n)) {
  31.       if (n <= 0)
  32.          n += nargs + 1;
  33.       if (n <= 0 || n > nargs)
  34.          return A_Resume;
  35.       *rslt = args[n - 1];
  36.       return A_Continue;
  37.       }
  38.    else if (cnv:string(callee, callee)) {
  39.       proc = strprc(&callee, (C_integer)nargs);
  40.       if (proc == NULL)
  41.          RunErr(106, &callee);
  42.       return (*(proc)->ccode)(nargs, args, rslt, succ_cont);
  43.       }
  44.    else 
  45.       RunErr(106, &callee);
  46.    }
  47.  
  48.  
  49. /*
  50.  * apply - implement binary bang. Construct an argument list for
  51.  *   invoke() from the callee and the list it is applied to.
  52.  */
  53. int apply(callee, strct, rslt, succ_cont)
  54. dptr callee;
  55. dptr strct;
  56. dptr rslt;
  57. continuation succ_cont;
  58.    {
  59.    tended struct descrip dstrct;
  60.    struct tend_desc *tnd_args;  /* place to tend arguments to invoke() */
  61.    union block *ep;
  62.    int nargs;
  63.    word i, j;
  64.    word indx;
  65.    int signal;
  66.  
  67.    deref(strct, &dstrct);
  68.  
  69.    switch (Type(dstrct)) {
  70.  
  71.       case T_List: {
  72.          /*
  73.           * Copy the arguments from the list into an tended array of descriptors.
  74.           */
  75.          nargs = BlkLoc(dstrct)->list.size + 1;
  76.          tnd_args = (struct tend_desc *)malloc((msize)(sizeof(struct tend_desc)
  77.             + (nargs - 1) * sizeof(struct descrip)));
  78.          if (tnd_args == NULL)
  79.             RunErr(305, NULL);
  80.       
  81.          tnd_args->d[0] = *callee;
  82.          indx = 1;
  83.          for (ep = BlkLoc(dstrct)->list.listhead;
  84.             ep != NULL; ep = ep->lelem.listnext) {
  85.             for (i = 0; i < ep->lelem.nused; i++) {
  86.                j = ep->lelem.first + i;
  87.                if (j >= ep->lelem.nslots)
  88.                   j -= ep->lelem.nslots;
  89.                tnd_args->d[indx++] = ep->lelem.lslots[j];
  90.                }
  91.             }
  92.          tnd_args->num = nargs;
  93.          tnd_args->previous = tend;
  94.          tend = tnd_args;
  95.       
  96.          signal = invoke(indx, tnd_args->d, rslt, succ_cont);
  97.       
  98.          tend = tnd_args->previous;
  99.          free(tnd_args);
  100.          return signal;
  101.          }
  102.       case T_Record: {
  103.          /*
  104.           * Copy the arguments from the record into an tended array
  105.           * of descriptors.
  106.           */
  107.          nargs = BlkLoc(dstrct)->record.recdesc->proc.nfields;
  108.          tnd_args = (struct tend_desc *)malloc((msize)(sizeof(struct tend_desc)
  109.             + (nargs - 1) * sizeof(struct descrip)));
  110.          if (tnd_args == NULL)
  111.             RunErr(305, NULL);
  112.       
  113.          tnd_args->d[0] = *callee;
  114.          indx = 1;
  115.          ep = BlkLoc(dstrct);
  116.          for (i = 0; i < nargs; i++)
  117.             tnd_args->d[indx++] = ep->record.fields[i];
  118.          tnd_args->num = nargs;
  119.          tnd_args->previous = tend;
  120.          tend = tnd_args;
  121.       
  122.          signal = invoke(indx, tnd_args->d, rslt, succ_cont);
  123.       
  124.          tend = tnd_args->previous;
  125.          free(tnd_args);
  126.          return signal;
  127.          }
  128.       default: {
  129.          RunErr(126, &dstrct);
  130.          }
  131.       }
  132.    }
  133.  
  134. #else                    /* COMPILER */
  135.  
  136. #ifdef EventMon
  137. #include "::h:opdefs.h"
  138. #endif                    /* EventMon */
  139.  
  140.  
  141. /*
  142.  * invoke -- Perform setup for invocation.  
  143.  */
  144. invoke(nargs,cargp,n)
  145. dptr *cargp;
  146. int nargs, *n;
  147. {
  148.    register struct pf_marker *newpfp;
  149.    register dptr newargp;
  150.    register word *newsp = sp;
  151.    tended struct descrip arg_sv;
  152.  
  153. #ifdef SCO_XENIX
  154.    register dptr p;
  155. #endif                    /* SCO_XENIX */
  156.  
  157.    register word i;
  158.    struct b_proc *proc;
  159.    int nparam;
  160.    char strbuf[MaxCvtLen];
  161.  
  162.    /*
  163.     * Point newargp at Arg0 and dereference it.
  164.     */
  165.    newargp = (dptr )(sp - 1) - nargs;
  166.  
  167.    xnargs = nargs;
  168.    xargp = newargp;
  169.  
  170.    Deref(newargp[0]);
  171.    
  172.    /*
  173.     * See what course the invocation is to take.
  174.     */
  175.    if (newargp->dword != D_Proc) {
  176.       C_integer tmp;
  177.       /*
  178.        * Arg0 is not a procedure.
  179.        */
  180.  
  181.       if (cnv:C_integer(newargp[0], tmp)) {
  182.          MakeInt(tmp,&newargp[0]);
  183.  
  184.          /*
  185.       * Arg0 is an integer, select result.
  186.       */
  187.          i = cvpos(IntVal(newargp[0]), (word)nargs);
  188.          if (i == CvtFail || i > nargs)
  189.             return I_Fail;
  190.  
  191. #ifdef SCO_XENIX
  192.          p = newargp + i;
  193.          newargp[0] = *p;
  194. #else                    /* SCO_XENIX */
  195.          newargp[0] = newargp[i];
  196. #endif                    /* SCO_XENIX */
  197.  
  198.          sp = (word *)newargp + 1;
  199.          return I_Continue;
  200.          }
  201.       else {
  202.          struct b_proc *tmp;
  203.          /*
  204.       * See if Arg0 can be converted to a string that names a procedure
  205.       *  or operator.  If not, generate run-time error 106.
  206.       */
  207.      if (!cnv:tmp_string(newargp[0],newargp[0]) ||
  208.          ((tmp = strprc(newargp, (C_integer)nargs)) == NULL)) {
  209.             err_msg(106, newargp);
  210.             return I_Fail;
  211.             }
  212.      BlkLoc(newargp[0]) = (union block *)tmp;
  213.      newargp[0].dword = D_Proc;
  214.      }
  215.       }
  216.    
  217.    /*
  218.     * newargp[0] is now a descriptor suitable for invocation.  Dereference
  219.     *  the supplied arguments.
  220.     */
  221.  
  222.    proc = (struct b_proc *)BlkLoc(newargp[0]);
  223.    if (proc->nstatic >= 0)    /* if negative, don't reference arguments */
  224.       for (i = 1; i <= nargs; i++)
  225.          Deref(newargp[i]);
  226.       
  227.    /*
  228.     * Adjust the argument list to conform to what the routine being invoked
  229.     *  expects (proc->nparam).  If nparam is less than 0, the number of
  230.     *  arguments is variable. For functions (ndynam = -1) with a
  231.     *  variable number of arguments, nothing need be done.  For Icon procedures
  232.     *  with a variable number of arguments, arguments beyond abs(nparam) are
  233.     *  put in a list which becomes the last argument.  For fix argument
  234.     *  routines, if too many arguments were supplied, adjusting the stack
  235.     *  pointer is all that is necessary. If too few arguments were supplied,
  236.     *  null descriptors are pushed for each missing argument.
  237.     */
  238.  
  239.    proc = (struct b_proc *)BlkLoc(newargp[0]);
  240.    nparam = (int)proc->nparam;
  241.    if (nparam >= 0) {
  242.       if (nargs > nparam)
  243.          newsp -= (nargs - nparam) * 2;
  244.       else if (nargs < nparam) {
  245.          i = nparam - nargs;
  246.          while (i--) {
  247.             *++newsp = D_Null;
  248.             *++newsp = 0;
  249.             }
  250.          }
  251.       nargs = nparam;
  252.  
  253.       xnargs = nargs;
  254.  
  255.       }
  256.    else {
  257.       if (proc->ndynam >= 0) { /* this is a procedure */
  258.          int lelems;
  259.      dptr llargp;
  260.  
  261.          if (nargs < abs(nparam) - 1) {
  262.             i = abs(nparam) - 1 - nargs;
  263.             while (i--) {
  264.                *++newsp = D_Null;
  265.                *++newsp = 0;
  266.                }
  267.             nargs = abs(nparam) - 1;
  268.             }
  269.  
  270.      lelems = nargs - (abs(nparam) - 1);
  271.          llargp = &newargp[abs(nparam)];
  272.          arg_sv = llargp[-1];
  273.  
  274.      Ollist(lelems, &llargp[-1]);
  275.  
  276.      llargp[0] = llargp[-1];
  277.      llargp[-1] = arg_sv;
  278.          /*
  279.           *  Reload proc pointer in case Ollist triggered a garbage collection.
  280.           */
  281.          proc = (struct b_proc *)BlkLoc(newargp[0]);
  282.      newsp = (word *)llargp + 1;
  283.      nargs = abs(nparam);
  284.      }
  285.       }
  286.  
  287.    if (proc->ndynam < 0) {
  288.       /*
  289.        * A function is being invoked, so nothing else here needs to be done.
  290.        */
  291.  
  292.       if (nargs < abs(nparam) - 1) {
  293.          i = abs(nparam) - 1 - nargs;
  294.          while (i--) {
  295.             *++newsp = D_Null;
  296.             *++newsp = 0;
  297.             }
  298.          nargs = abs(nparam) - 1;
  299.          }
  300.  
  301.       *n = nargs;
  302.       *cargp = newargp;
  303.       sp = newsp;
  304.  
  305.       EVVal((word)Op_Invoke,E_Ecall);
  306.  
  307.       if ((nparam < 0) || (proc->ndynam == -2))
  308.          return I_Vararg;
  309.       else
  310.          return I_Builtin;
  311.       }
  312.  
  313. #ifndef MultiThread
  314.    /*
  315.     * Make a stab at catching interpreter stack overflow.  This does
  316.     * nothing for invocation in a co-expression other than &main.
  317.     */
  318.    if (BlkLoc(k_current) == BlkLoc(k_main) &&
  319.       ((char *)sp + PerilDelta) > (char *)stackend) 
  320.          fatalerr(301, NULL);
  321. #endif                    /* MultiThread */
  322.  
  323.    /*
  324.     * Build the procedure frame.
  325.     */
  326.    newpfp = (struct pf_marker *)(newsp + 1);
  327.    newpfp->pf_nargs = nargs;
  328.    newpfp->pf_argp = argp;
  329.    newpfp->pf_pfp = pfp;
  330.    newpfp->pf_ilevel = ilevel;
  331.    newpfp->pf_scan = NULL;
  332.  
  333.    newpfp->pf_ipc = ipc;
  334.    newpfp->pf_gfp = gfp;
  335.    newpfp->pf_efp = efp;
  336.  
  337. #ifdef MultiThread
  338.    newpfp->pf_prog = curpstate;
  339. #endif                    /* MultiThread */
  340.  
  341.    argp = newargp;
  342.    pfp = newpfp;
  343.    newsp += Vwsizeof(*pfp);
  344.  
  345.    /*
  346.     * If tracing is on, use ctrace to generate a message.
  347.     */   
  348.    if (k_trace) {
  349.       k_trace--;
  350.       ctrace(&(proc->pname), nargs, &newargp[1]);
  351.       }
  352.    
  353.    /*
  354.     * Point ipc at the icode entry point of the procedure being invoked.
  355.     */
  356.    ipc.opnd = (word *)proc->entryp.icode;
  357.  
  358. #ifdef MultiThread
  359.    /*
  360.     * Enter the program state of the procedure being invoked.
  361.     */
  362.    ENTERPSTATE(proc->program);
  363. #endif                    /* MultiThread */
  364.  
  365.    efp = 0;
  366.    gfp = 0;
  367.  
  368.    /*
  369.     * Push a null descriptor on the stack for each dynamic local.
  370.     */
  371.    for (i = proc->ndynam; i > 0; i--) {
  372.       *++newsp = D_Null;
  373.       *++newsp = 0;
  374.       }
  375.    sp = newsp;
  376.    k_level++;
  377.  
  378.    EVValD(newargp, E_Pcall);
  379.  
  380.    return I_Continue;
  381. }
  382.  
  383. #endif                    /* COMPILER */
  384.