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