diff options
Diffstat (limited to 'src/runtime/invoke.r')
| -rw-r--r-- | src/runtime/invoke.r | 377 |
1 files changed, 377 insertions, 0 deletions
diff --git a/src/runtime/invoke.r b/src/runtime/invoke.r new file mode 100644 index 0000000..87b9fd1 --- /dev/null +++ b/src/runtime/invoke.r @@ -0,0 +1,377 @@ +/* + * invoke.r - contains invoke, apply + */ + +#if COMPILER + +/* + * invoke - perform general invocation on a value. + */ +int invoke(nargs, args, rslt, succ_cont) +int nargs; +dptr args; +dptr rslt; +continuation succ_cont; + { + tended struct descrip callee; + struct b_proc *proc; + C_integer n; + + /* + * remove the operation being called from the argument list. + */ + deref(&args[0], &callee); + ++args; + nargs -= 1; + + if (is:proc(callee)) + return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt, + succ_cont); + else if (cnv:C_integer(callee, n)) { + if (n <= 0) + n += nargs + 1; + if (n <= 0 || n > nargs) + return A_Resume; + *rslt = args[n - 1]; + return A_Continue; + } + else if (cnv:string(callee, callee)) { + proc = strprc(&callee, (C_integer)nargs); + if (proc == NULL) + RunErr(106, &callee); + return (*(proc)->ccode)(nargs, args, rslt, succ_cont); + } + else + RunErr(106, &callee); + } + + +/* + * apply - implement binary bang. Construct an argument list for + * invoke() from the callee and the list it is applied to. + */ +int apply(callee, strct, rslt, succ_cont) +dptr callee; +dptr strct; +dptr rslt; +continuation succ_cont; + { + tended struct descrip dstrct; + struct tend_desc *tnd_args; /* place to tend arguments to invoke() */ + union block *ep; + int nargs; + word i, j; + word indx; + int signal; + + deref(strct, &dstrct); + + switch (Type(dstrct)) { + + case T_List: { + /* + * Copy the arguments from the list into an tended array of descriptors. + */ + nargs = BlkLoc(dstrct)->list.size + 1; + tnd_args = malloc(sizeof(struct tend_desc) + + (nargs - 1) * sizeof(struct descrip)); + if (tnd_args == NULL) + RunErr(305, NULL); + + tnd_args->d[0] = *callee; + indx = 1; + for (ep = BlkLoc(dstrct)->list.listhead; +#ifdef ListFix + BlkType(ep) == T_Lelem; +#else /* ListFix */ + ep != NULL; +#endif /* ListFix */ + ep = ep->lelem.listnext) { + for (i = 0; i < ep->lelem.nused; i++) { + j = ep->lelem.first + i; + if (j >= ep->lelem.nslots) + j -= ep->lelem.nslots; + tnd_args->d[indx++] = ep->lelem.lslots[j]; + } + } + tnd_args->num = nargs; + tnd_args->previous = tend; + tend = tnd_args; + + signal = invoke(indx, tnd_args->d, rslt, succ_cont); + + tend = tnd_args->previous; + free(tnd_args); + return signal; + } + case T_Record: { + /* + * Copy the arguments from the record into an tended array + * of descriptors. + */ + nargs = BlkLoc(dstrct)->record.recdesc->proc.nfields; + tnd_args = malloc(sizeof(struct tend_desc) + + (nargs - 1) * sizeof(struct descrip)); + if (tnd_args == NULL) + RunErr(305, NULL); + + tnd_args->d[0] = *callee; + indx = 1; + ep = BlkLoc(dstrct); + for (i = 0; i < nargs; i++) + tnd_args->d[indx++] = ep->record.fields[i]; + tnd_args->num = nargs; + tnd_args->previous = tend; + tend = tnd_args; + + signal = invoke(indx, tnd_args->d, rslt, succ_cont); + + tend = tnd_args->previous; + free(tnd_args); + return signal; + } + default: { + RunErr(126, &dstrct); + } + } + } + +#else /* COMPILER */ + +#ifdef EventMon +#include "../h/opdefs.h" +#endif /* EventMon */ + + +/* + * invoke -- Perform setup for invocation. + */ +int invoke(nargs,cargp,n) +dptr *cargp; +int nargs, *n; +{ + register struct pf_marker *newpfp; + register dptr newargp; + register word *newsp = sp; + tended struct descrip arg_sv; + register word i; + struct b_proc *proc; + int nparam; + + /* + * Point newargp at Arg0 and dereference it. + */ + newargp = (dptr )(sp - 1) - nargs; + + xnargs = nargs; + xargp = newargp; + + Deref(newargp[0]); + + /* + * See what course the invocation is to take. + */ + if (newargp->dword != D_Proc) { + C_integer tmp; + /* + * Arg0 is not a procedure. + */ + + if (cnv:C_integer(newargp[0], tmp)) { + MakeInt(tmp,&newargp[0]); + + /* + * Arg0 is an integer, select result. + */ + i = cvpos(IntVal(newargp[0]), (word)nargs); + if (i == CvtFail || i > nargs) + return I_Fail; + newargp[0] = newargp[i]; + sp = (word *)newargp + 1; + return I_Continue; + } + else { + struct b_proc *tmp; + /* + * See if Arg0 can be converted to a string that names a procedure + * or operator. If not, generate run-time error 106. + */ + if (!cnv:tmp_string(newargp[0],newargp[0]) || + ((tmp = strprc(newargp, (C_integer)nargs)) == NULL)) { + err_msg(106, newargp); + return I_Fail; + } + BlkLoc(newargp[0]) = (union block *)tmp; + newargp[0].dword = D_Proc; + } + } + + /* + * 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++) + Deref(newargp[i]); + + /* + * 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; + + xnargs = nargs; + + } + else { + if (proc->ndynam >= 0) { /* this is a procedure */ + 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)]; + arg_sv = llargp[-1]; + + Ollist(lelems, &llargp[-1]); + + llargp[0] = llargp[-1]; + llargp[-1] = arg_sv; + /* + * 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. + */ + + if (nargs < abs(nparam) - 1) { + i = abs(nparam) - 1 - nargs; + while (i--) { + *++newsp = D_Null; + *++newsp = 0; + } + nargs = abs(nparam) - 1; + } + + *n = nargs; + *cargp = newargp; + sp = newsp; + + EVVal((word)Op_Invoke,E_Ecall); + + if ((nparam < 0) || (proc->ndynam == -2)) + return I_Vararg; + else + return I_Builtin; + } + +#ifndef MultiThread + /* + * 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); +#endif /* MultiThread */ + + /* + * Build the procedure frame. + */ + newpfp = (struct pf_marker *)(newsp + 1); + newpfp->pf_nargs = nargs; + newpfp->pf_argp = glbl_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; + +#ifdef MultiThread + newpfp->pf_prog = curpstate; +#endif /* MultiThread */ + + glbl_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; + +#ifdef MultiThread + /* + * Enter the program state of the procedure being invoked. + */ + if (!InRange(code, ipc.opnd, ecode)) { + syserr("interprogram procedure calls temporarily prohibited\n"); + } +#endif /* MultiThread */ + + 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++; + + EVValD(newargp, E_Pcall); + + return I_Continue; +} + +#endif /* COMPILER */ |