The R Project SVN – R – Diff – /branches/R-exp-API/src/main/objects.c



 
    /* Get the context which UseMethod was called from. */
 
    cptr = R_GlobalContext;
    if (cptr->callflag != CTXT_RETURN || cptr->cloenv != rho)
	error("UseMethod used in an inappropriate fashion");
 
    /* Create a new environment without any */
    /* of the formals to the generic in it. */
 
    PROTECT(newrho = allocSExp(ENVSXP));

    RCNTXT *cptr;
 
    nargs = length(args);
 
if (nargs < 0)
    errorcall(call, "corrupt internals!");
 
    if (nargs)
	PROTECT(meth = eval(CAR(args), env));
    else
	meth = R_MissingArg;

	    if (cptr->callflag == CTXT_RETURN && cptr->cloenv == env)
		break;
	    cptr = cptr->nextcontext;
	}
	if (cptr == NULL)
	    error("UseMethod called from outside a closure");
	if (meth == R_MissingArg)
	    PROTECT(meth = mkString(CHAR(PRINTNAME(CAR(cptr->call)))));
	PROTECT(obj = GetObject(cptr));
    }
 
    if (TYPEOF(meth) != STRSXP ||
	LENGTH(meth) < 1 ||
	strlen(CHAR(STRING(meth)[0])) == 0)
	errorcall(call, "first argument must be a method name");
 
    strcpy(buf, CHAR(STRING(meth)[0]));
 
    if (usemethod(buf, obj, call, CDR(args), env, &ans) == 1) {
	UNPROTECT(1);
	PROTECT(ans);
	findcontext(CTXT_RETURN, env, ans);
	UNPROTECT(1);
    }
    else
	error("no applicable method for \"%s\"", buf);
    return R_NilValue; /* NOT Used */
}
 
/*
   fixcall: fixes up the call when arguments to the function may

	if (cptr->callflag == CTXT_RETURN && cptr->cloenv == sysp)
	    break;
	cptr = cptr->nextcontext;
    }
    if (cptr == NULL)
	error("NextMethod called from outside a closure");
 
    PROTECT(newcall = duplicate(cptr->call));
 
    /* set up the arglist */
    s = findFun(CAR(cptr->call), cptr->sysparent);
    if (TYPEOF(s) != CLOSXP)
	errorcall(cptr->call, "function is not a closure");
 
    /* get formals and actuals; attach the names of the formals to
       the actuals, expanding any ... that occurs */
    formals = FORMALS(s);
    PROTECT(actuals = matchArgs(formals, cptr->promargs));

	    PROTECT(matchedarg = s);
	    newcall = fixcall(newcall, matchedarg);
	}
    }
    else
	errorcall(call,"wrong argument ...");
 
    /*
      .Class is used to determine the next method; if it doesn't
      exist the first argument to the current method is used
      the second argument to NextMethod is another option but

    class = dynamicfindVar(install(".Class"), R_GlobalContext);
 
    if (class == R_UnboundValue) {
	s = GetObject(cptr);
	if (!isObject(s))
	    errorcall(call, "object not specified");
	class = getAttrib(s, R_ClassSymbol);
    }
 
    generic = eval(CAR(args), env);
    if (generic == R_NilValue) {

	    generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))));
    }
    PROTECT(generic);
 
    if (!isString(generic) || length(generic) > 1)
	errorcall(call,"invalid generic argument to NextMethod");
    if (strlen(CHAR(STRING(generic)[0])) == 0)
	errorcall(call,"generic function not specified");
 
    group = dynamicfindVar(install(".Group"), R_GlobalContext);
    PROTECT(realgroup = duplicate(group));
    if (group == R_UnboundValue){
	group = generic;
	UNPROTECT(1);
	PROTECT(realgroup = mkString(""));
    }
    if (!isString(group) || length(group) > 1)
	errorcall(call, "invalid group argument found in NextMethod");
    if (strlen(CHAR(STRING(group)[0])) == 0)
	group = generic;
 
    /* we need the value of i on exit from the for loop to figure out
       how many classes to drop

	nextfun = findVar(install(buf), env);
	if (!isFunction(nextfun)) {
	    t = install(CHAR(STRING(generic)[0]));
	    nextfun = findVar(t,env);
	    if (!isFunction(nextfun))
		error("No method to invoke");
	    if (TYPEOF(nextfun) == CLOSXP) {
		if (INTERNAL(t) != R_NilValue)
		    nextfun = INTERNAL(t);
		else
		    error("No method to invoke");
	    }
	}
    }
    PROTECT(s = allocVector(STRSXP, length(class) - i));
    PROTECT(class = duplicate(class));

Rev 5458	Rev 5731
Line 126...	Line 126...
126		126
127	`/* Get the context which UseMethod was called from. */`	127	`/* Get the context which UseMethod was called from. */`
128		128
129	`cptr = R_GlobalContext;`	129	`cptr = R_GlobalContext;`
130	`if (cptr->callflag != CTXT_RETURN \|\| cptr->cloenv != rho)`	130	`if (cptr->callflag != CTXT_RETURN \|\| cptr->cloenv != rho)`
131	`error("UseMethod used in an inappropriate fashion\n");`	131	`error("UseMethod used in an inappropriate fashion");`
132		132
133	`/* Create a new environment without any */`	133	`/* Create a new environment without any */`
134	`/* of the formals to the generic in it. */`	134	`/* of the formals to the generic in it. */`
135		135
136	`PROTECT(newrho = allocSExp(ENVSXP));`	136	`PROTECT(newrho = allocSExp(ENVSXP));`
Line 216...	Line 216...
216	`RCNTXT *cptr;`	216	`RCNTXT *cptr;`
217		217
218	`nargs = length(args);`	218	`nargs = length(args);`
219		219
220	`if (nargs < 0)`	220	`if (nargs < 0)`
221	`errorcall(call, "corrupt internals!\n");`	221	`errorcall(call, "corrupt internals!");`
222		222
223	`if (nargs)`	223	`if (nargs)`
224	`PROTECT(meth = eval(CAR(args), env));`	224	`PROTECT(meth = eval(CAR(args), env));`
225	`else`	225	`else`
226	`meth = R_MissingArg;`	226	`meth = R_MissingArg;`
Line 233...	Line 233...
233	`if (cptr->callflag == CTXT_RETURN && cptr->cloenv == env)`	233	`if (cptr->callflag == CTXT_RETURN && cptr->cloenv == env)`
234	`break;`	234	`break;`
235	`cptr = cptr->nextcontext;`	235	`cptr = cptr->nextcontext;`
236	`}`	236	`}`
237	`if (cptr == NULL)`	237	`if (cptr == NULL)`
238	`error("UseMethod called from outside a closure\n");`	238	`error("UseMethod called from outside a closure");`
239	`if (meth == R_MissingArg)`	239	`if (meth == R_MissingArg)`
240	`PROTECT(meth = mkString(CHAR(PRINTNAME(CAR(cptr->call)))));`	240	`PROTECT(meth = mkString(CHAR(PRINTNAME(CAR(cptr->call)))));`
241	`PROTECT(obj = GetObject(cptr));`	241	`PROTECT(obj = GetObject(cptr));`
242	`}`	242	`}`
243		243
244	`if (TYPEOF(meth) != STRSXP \|\|`	244	`if (TYPEOF(meth) != STRSXP \|\|`
245	`LENGTH(meth) < 1 \|\|`	245	`LENGTH(meth) < 1 \|\|`
246	`strlen(CHAR(STRING(meth)[0])) == 0)`	246	`strlen(CHAR(STRING(meth)[0])) == 0)`
247	`errorcall(call, "first argument must be a method name\n");`	247	`errorcall(call, "first argument must be a method name");`
248		248
249	`strcpy(buf, CHAR(STRING(meth)[0]));`	249	`strcpy(buf, CHAR(STRING(meth)[0]));`
250		250
251	`if (usemethod(buf, obj, call, CDR(args), env, &ans) == 1) {`	251	`if (usemethod(buf, obj, call, CDR(args), env, &ans) == 1) {`
252	`UNPROTECT(1);`	252	`UNPROTECT(1);`
253	`PROTECT(ans);`	253	`PROTECT(ans);`
254	`findcontext(CTXT_RETURN, env, ans);`	254	`findcontext(CTXT_RETURN, env, ans);`
255	`UNPROTECT(1);`	255	`UNPROTECT(1);`
256	`}`	256	`}`
257	`else`	257	`else`
258	`error("no applicable method for \"%s\"\n", buf);`	258	`error("no applicable method for \"%s\"", buf);`
259	`return R_NilValue; /* NOT Used */`	259	`return R_NilValue; /* NOT Used */`
260	`}`	260	`}`
261		261
262	`/*`	262	`/*`
263	`fixcall: fixes up the call when arguments to the function may`	263	`fixcall: fixes up the call when arguments to the function may`
Line 313...	Line 313...
313	`if (cptr->callflag == CTXT_RETURN && cptr->cloenv == sysp)`	313	`if (cptr->callflag == CTXT_RETURN && cptr->cloenv == sysp)`
314	`break;`	314	`break;`
315	`cptr = cptr->nextcontext;`	315	`cptr = cptr->nextcontext;`
316	`}`	316	`}`
317	`if (cptr == NULL)`	317	`if (cptr == NULL)`
318	`error("NextMethod called from outside a closure\n");`	318	`error("NextMethod called from outside a closure");`
319		319
320	`PROTECT(newcall = duplicate(cptr->call));`	320	`PROTECT(newcall = duplicate(cptr->call));`
321		321
322	`/* set up the arglist */`	322	`/* set up the arglist */`
323	`s = findFun(CAR(cptr->call), cptr->sysparent);`	323	`s = findFun(CAR(cptr->call), cptr->sysparent);`
324	`if (TYPEOF(s) != CLOSXP)`	324	`if (TYPEOF(s) != CLOSXP)`
325	`errorcall(cptr->call, "function is not a closure\n");`	325	`errorcall(cptr->call, "function is not a closure");`
326		326
327	`/* get formals and actuals; attach the names of the formals to`	327	`/* get formals and actuals; attach the names of the formals to`
328	`the actuals, expanding any ... that occurs */`	328	`the actuals, expanding any ... that occurs */`
329	`formals = FORMALS(s);`	329	`formals = FORMALS(s);`
330	`PROTECT(actuals = matchArgs(formals, cptr->promargs));`	330	`PROTECT(actuals = matchArgs(formals, cptr->promargs));`
Line 403...	Line 403...
403	`PROTECT(matchedarg = s);`	403	`PROTECT(matchedarg = s);`
404	`newcall = fixcall(newcall, matchedarg);`	404	`newcall = fixcall(newcall, matchedarg);`
405	`}`	405	`}`
406	`}`	406	`}`
407	`else`	407	`else`
408	`errorcall(call,"wrong argument ...\n");`	408	`errorcall(call,"wrong argument ...");`
409		409
410	`/*`	410	`/*`
411	`.Class is used to determine the next method; if it doesn't`	411	`.Class is used to determine the next method; if it doesn't`
412	`exist the first argument to the current method is used`	412	`exist the first argument to the current method is used`
413	`the second argument to NextMethod is another option but`	413	`the second argument to NextMethod is another option but`
Line 417...	Line 417...
417	`class = dynamicfindVar(install(".Class"), R_GlobalContext);`	417	`class = dynamicfindVar(install(".Class"), R_GlobalContext);`
418		418
419	`if (class == R_UnboundValue) {`	419	`if (class == R_UnboundValue) {`
420	`s = GetObject(cptr);`	420	`s = GetObject(cptr);`
421	`if (!isObject(s))`	421	`if (!isObject(s))`
422	`errorcall(call, "object not specified\n");`	422	`errorcall(call, "object not specified");`
423	`class = getAttrib(s, R_ClassSymbol);`	423	`class = getAttrib(s, R_ClassSymbol);`
424	`}`	424	`}`
425		425
426	`generic = eval(CAR(args), env);`	426	`generic = eval(CAR(args), env);`
427	`if (generic == R_NilValue) {`	427	`if (generic == R_NilValue) {`
Line 430...	Line 430...
430	`generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))));`	430	`generic = mkString(CHAR(PRINTNAME(CAR(cptr->call))));`
431	`}`	431	`}`
432	`PROTECT(generic);`	432	`PROTECT(generic);`
433		433
434	`if (!isString(generic) \|\| length(generic) > 1)`	434	`if (!isString(generic) \|\| length(generic) > 1)`
435	`errorcall(call,"invalid generic argument to NextMethod\n");`	435	`errorcall(call,"invalid generic argument to NextMethod");`
436	`if (strlen(CHAR(STRING(generic)[0])) == 0)`	436	`if (strlen(CHAR(STRING(generic)[0])) == 0)`
437	`errorcall(call,"generic function not specified\n");`	437	`errorcall(call,"generic function not specified");`
438		438
439	`group = dynamicfindVar(install(".Group"), R_GlobalContext);`	439	`group = dynamicfindVar(install(".Group"), R_GlobalContext);`
440	`PROTECT(realgroup = duplicate(group));`	440	`PROTECT(realgroup = duplicate(group));`
441	`if (group == R_UnboundValue){`	441	`if (group == R_UnboundValue){`
442	`group = generic;`	442	`group = generic;`
443	`UNPROTECT(1);`	443	`UNPROTECT(1);`
444	`PROTECT(realgroup = mkString(""));`	444	`PROTECT(realgroup = mkString(""));`
445	`}`	445	`}`
446	`if (!isString(group) \|\| length(group) > 1)`	446	`if (!isString(group) \|\| length(group) > 1)`
447	`errorcall(call, "invalid group argument found in NextMethod\n");`	447	`errorcall(call, "invalid group argument found in NextMethod");`
448	`if (strlen(CHAR(STRING(group)[0])) == 0)`	448	`if (strlen(CHAR(STRING(group)[0])) == 0)`
449	`group = generic;`	449	`group = generic;`
450		450
451	`/* we need the value of i on exit from the for loop to figure out`	451	`/* we need the value of i on exit from the for loop to figure out`
452	`how many classes to drop`	452	`how many classes to drop`
Line 483...	Line 483...
483	`nextfun = findVar(install(buf), env);`	483	`nextfun = findVar(install(buf), env);`
484	`if (!isFunction(nextfun)) {`	484	`if (!isFunction(nextfun)) {`
485	`t = install(CHAR(STRING(generic)[0]));`	485	`t = install(CHAR(STRING(generic)[0]));`
486	`nextfun = findVar(t,env);`	486	`nextfun = findVar(t,env);`
487	`if (!isFunction(nextfun))`	487	`if (!isFunction(nextfun))`
488	`error("No method to invoke\n");`	488	`error("No method to invoke");`
489	`if (TYPEOF(nextfun) == CLOSXP) {`	489	`if (TYPEOF(nextfun) == CLOSXP) {`
490	`if (INTERNAL(t) != R_NilValue)`	490	`if (INTERNAL(t) != R_NilValue)`
491	`nextfun = INTERNAL(t);`	491	`nextfun = INTERNAL(t);`
492	`else`	492	`else`
493	`error("No method to invoke\n");`	493	`error("No method to invoke");`
494	`}`	494	`}`
495	`}`	495	`}`
496	`}`	496	`}`
497	`PROTECT(s = allocVector(STRSXP, length(class) - i));`	497	`PROTECT(s = allocVector(STRSXP, length(class) - i));`
498	`PROTECT(class = duplicate(class));`	498	`PROTECT(class = duplicate(class));`

The R Project SVN R

(root)/branches/R-exp-API/src/main/objects.c @ 28362 – Rev 5458 → 5731