APDL Public Domain 1/APDL_PD1A.iso/program/language/icon/Source/Iconx/C/Invoke

Text File | 1990-07-19 | 5.5 KB | 231 lines

/*
 * Procedure and function invocation.
 */

#include <math.h>
#include "../h/config.h"
#include "../h/rt.h"
#include "rproto.h"

#ifdef TraceBack
extern dptr xargp;
extern word xnargs;
#endif                     /* TraceBack */

/*
 * invoke -- Perform setup for invocation.
 */
invoke(nargs,cargp,n)
dptr *cargp;
int nargs, *n;
{
   register struct pf_marker *newpfp;
   register dptr newargp;
   register word *newsp = sp;

#ifdef SCO_XENIX
   register dptr p;
#endif                    /* SCO_XENIX */

   register word i;
   struct b_proc *proc;
   int nparam;
   char strbuf[MaxCvtLen];

   /*
    * Point newargp at Arg0 and dereference it.
    */
   newargp = (dptr )(sp - 1) - nargs;

#ifdef TraceBack
   xnargs = nargs;
   xargp = newargp;
#endif                    /* TraceBack */

   if (DeRef(newargp[0]) == Error) {
      runerr(0, NULL);
      return I_Fail;
      }

   /*
    * See what course the invocation is to take.
    */
   if (newargp->dword != D_Proc) {
      /*
       * Arg0 is not a procedure.
       */
      if (cvint(&newargp[0]) == T_Integer) {
         /*
      * Arg0 is an integer, select result.
      */
         i = cvpos(IntVal(newargp[0]), (word)nargs);
         if (i == CvtFail || i > nargs)
            return I_Fail;

#ifdef SCO_XENIX
         p = newargp + i;
         newargp[0] = *p;
#else                    /* SCO_XENIX */
         newargp[0] = newargp[i];
#endif                    /* SCO_XENIX */

         sp = (word *)newargp + 1;
         return I_Continue;
         }
      else {
         /*
      * See if Arg0 can be converted to a string that names a procedure
      *  or operator.  If not, generate run-time error 106.
      */
         if (cvstr(&newargp[0],strbuf) == CvtFail || strprc(&newargp[0],
            (word)nargs) == CvtFail) {
               runerr(106, newargp);
               return I_Fail;
            }
     }
      }

   /*
    * newargp[0] is now a descriptor suitable for invocation.  Dereference
    *  the supplied arguments.
    */
   proc = (struct b_proc *)BlkLoc(newargp[0]);
   if (proc->nstatic >= 0)    /* if negative, don't reference arguments */
      for (i = 1; i <= nargs; i++)
         if (DeRef(newargp[i]) == Error) {
            runerr(0, NULL);
            return I_Fail;
            }

   /*
    * Adjust the argument list to conform to what the routine being invoked
    *  expects (proc->nparam).  If nparam is less than 0, the number of
    *  arguments is variable. For functions (ndynam = -1) with a
    *  variable number of arguments, nothing need be done.  For Icon procedures
    *  with a variable number of arguments, arguments beyond abs(nparam) are
    *  put in a list which becomes the last argument.  For fix argument
    *  routines, if too many arguments were supplied, adjusting the stack
    *  pointer is all that is necessary. If too few arguments were supplied,
    *  null descriptors are pushed for each missing argument.
    */
   proc = (struct b_proc *)BlkLoc(newargp[0]);
   nparam = (int)proc->nparam;
   if (nparam >= 0) {
      if (nargs > nparam)
         newsp -= (nargs - nparam) * 2;
      else if (nargs < nparam) {
         i = nparam - nargs;
         while (i--) {
            *++newsp = D_Null;
            *++newsp = 0;
            }
         }
      nargs = nparam;

#ifdef TraceBack
      xnargs = nargs;
#endif                    /* TraceBack */

      }
   else {
      if (proc->ndynam >= 0) {
         int lelems;
     dptr llargp;

         if (nargs < abs(nparam) - 1) {
            i = abs(nparam) - 1 - nargs;
            while (i--) {
               *++newsp = D_Null;
               *++newsp = 0;
               }
            nargs = abs(nparam) - 1;
            }

     lelems = nargs - (abs(nparam) - 1);
         llargp = &newargp[abs(nparam)];
         tended[1] = llargp[-1];
         ntended = 1;

     Ollist(lelems, &llargp[-1]);

     llargp[0] = llargp[-1];
     llargp[-1] = tended[1];
         ntended = 0;
         /*
          *  Reload proc pointer in case Ollist triggered a garbage collection.
          */
         proc = (struct b_proc *)BlkLoc(newargp[0]);
     newsp = (word *)llargp + 1;
     nargs = abs(nparam);
     }
      }

   if (proc->ndynam < 0) {
      /*
       * A function is being invoked, so nothing else here needs to be done.
       */
      *n = nargs;
      *cargp = newargp;

      sp = newsp;


      if ((nparam == -1) || (proc->ndynam == -2))
         return I_Vararg;
      else
         return I_Builtin;
      }

   /*
    * Make a stab at catching interpreter stack overflow.  This does
    * nothing for invocation in a co-expression other than &main.
    */
   if (BlkLoc(k_current) == BlkLoc(k_main) &&
      ((char *)sp + PerilDelta) > (char *)stackend)
         fatalerr(-301, NULL);
   /*
    * Build the procedure frame.
    */
   newpfp = (struct pf_marker *)(newsp + 1);
   newpfp->pf_nargs = nargs;
   newpfp->pf_argp = argp;
   newpfp->pf_pfp = pfp;
   newpfp->pf_ilevel = ilevel;
   newpfp->pf_scan = NULL;

   newpfp->pf_ipc = ipc;
   newpfp->pf_gfp = gfp;
   newpfp->pf_efp = efp;

   argp = newargp;
   pfp = newpfp;
   newsp += Vwsizeof(*pfp);

   /*
    * If tracing is on, use ctrace to generate a message.
    */
   if (k_trace) {
      k_trace--;
      ctrace(&(proc->pname), nargs, &newargp[1]);
      }

   /*
    * Point ipc at the icode entry point of the procedure being invoked.
    */
   ipc.opnd = (word *)proc->entryp.icode;
   efp = 0;
   gfp = 0;

   /*
    * Push a null descriptor on the stack for each dynamic local.
    */
   for (i = proc->ndynam; i > 0; i--) {
      *++newsp = D_Null;
      *++newsp = 0;
      }

   sp = newsp;
   k_level++;
   return I_Continue;
}