The R Project SVN R

Rev

Rev 51267 | Rev 52273 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 51267 Rev 52266
Line 248... Line 248...
248
248
249 
 
 249 
 
250 
int usemethod(const char *generic, SEXP obj, SEXP call, SEXP args,
 250 
int usemethod(const char *generic, SEXP obj, SEXP call, SEXP args,
251 
	      SEXP rho, SEXP callrho, SEXP defrho, SEXP *ans)
 251 
	      SEXP rho, SEXP callrho, SEXP defrho, SEXP *ans)
252 
{
 252 
{
253 
    SEXP klass, method, sxp, t, s, matchedarg;
 253 
    SEXP klass, method, sxp, t, s, matchedarg, sort_list;
254 
    SEXP op, formals, newrho, newcall, match_obj = 0;
 254 
    SEXP op, formals, newrho, newcall, match_obj = 0;
255 
    char buf[512];
 255 
    char buf[512];
256 
    int i, j, nclass, matched, S4toS3, nprotect;
 256 
    int i, j, nclass, matched, S4toS3, nprotect;
257 
    RCNTXT *cptr;
 257 
    RCNTXT *cptr;
258 
 
 258 
 
Line 300... Line 300...
300 
 
 300 
 
301 
    PROTECT(matchedarg = cptr->promargs);
 301 
    PROTECT(matchedarg = cptr->promargs);
302 
    PROTECT(newcall = duplicate(cptr->call));
 302 
    PROTECT(newcall = duplicate(cptr->call));
303 
 
 303 
 
304 
    PROTECT(klass = R_data_class2(obj));
 304 
    PROTECT(klass = R_data_class2(obj));
305 
    S4toS3 = IS_S4_OBJECT(obj);
 305 
    sort_list = install("sort.list");
306 
 
 306 
 
307 
    nclass = length(klass);
 307 
    nclass = length(klass);
308 
    for (i = 0; i < nclass; i++) {
 308 
    for (i = 0; i < nclass; i++) {
309 
        const char *ss = translateChar(STRING_ELT(klass, i));
 309 
        const char *ss = translateChar(STRING_ELT(klass, i));
310 
	if(strlen(generic) + strlen(ss) + 2 > 512)
 310 
	if(strlen(generic) + strlen(ss) + 2 > 512)
311 
	    error(_("class name too long in '%s'"), generic);
 311 
	    error(_("class name too long in '%s'"), generic);
312 
	sprintf(buf, "%s.%s", generic, ss);
 312 
	sprintf(buf, "%s.%s", generic, ss);
313 
	method = install(buf);
 313 
	method = install(buf);
314 
	sxp = R_LookupMethod(method, rho, callrho, defrho);
 314 
	sxp = R_LookupMethod(method, rho, callrho, defrho);
315 
	if (isFunction(sxp)) {
 315 
	if (isFunction(sxp)) {
- 
 
 316 
	    if(method == sort_list && CLOENV(sxp) == R_BaseNamespace)
- 
 
 317 
		continue; /* kludge because sort.list is not a method */
316 
            if( RDEBUG(op) || RSTEP(op) )
 318 
            if( RDEBUG(op) || RSTEP(op) )
317 
                SET_RSTEP(sxp, 1);
 319 
                SET_RSTEP(sxp, 1);
318 
	    defineVar(install(".Generic"), mkString(generic), newrho);
 320 
	    defineVar(install(".Generic"), mkString(generic), newrho);
319 
	    if (i > 0) {
 321 
	    if (i > 0) {
320 
	        int ii;
 322 
	        int ii;
Line 329... Line 331...
329 
	    PROTECT(t = mkString(buf));
 331 
	    PROTECT(t = mkString(buf));
330 
	    defineVar(install(".Method"), t, newrho);
 332 
	    defineVar(install(".Method"), t, newrho);
331 
	    UNPROTECT(1);
 333 
	    UNPROTECT(1);
332 
	    defineVar(install(".GenericCallEnv"), callrho, newrho);
 334 
	    defineVar(install(".GenericCallEnv"), callrho, newrho);
333 
	    defineVar(install(".GenericDefEnv"), defrho, newrho);
 335 
	    defineVar(install(".GenericDefEnv"), defrho, newrho);
334 
	    if(S4toS3 && i > 0 && isBasicClass(ss)) {
 - 
 
335 
	      SEXP S3Part;
- 
 
336 
	      S3Part = R_getS4DataSlot(obj, S4SXP);
 - 
 
337 
	      if(S3Part == R_NilValue && TYPEOF(obj) == S4SXP) /* could be type, e.g. "environment" */
 - 
 
338 
		S3Part = R_getS4DataSlot(obj, ANYSXP);
 - 
 
339 
	      PROTECT(S3Part); nprotect++;
 - 
 
340 
	      /* At this point S3Part is the S3 class object or
 - 
 
341 
	       an object of an abnormal type, or NULL */
 - 
 
342 
	      if(S3Part != R_NilValue) {  /* use S3Part as inherited object */
 - 
 
343 
		  obj = S3Part;
 - 
 
344 
		  if(!match_obj) /* use the first arg, for "[",e.g. */
 - 
 
345 
		    match_obj = CAR(matchedarg);
 - 
 
346 
		  if(NAMED(obj)) SET_NAMED(obj, 2);
 - 
 
347 
		  if(TYPEOF(match_obj) == PROMSXP)
 - 
 
348 
		    SET_PRVALUE(match_obj, obj); /* must have been eval'd */
 - 
 
349 
		  else /* not possible ?*/
 - 
 
350 
		    defineVar(TAG(FORMALS(sxp)), obj, newrho);
 - 
 
351 
	      } /* else, use the S4 object */
 - 
 
352 
	    }
 - 
 
353 
	    t = newcall;
 336 
	    t = newcall;
354 
	    SETCAR(t, method);
 337 
	    SETCAR(t, method);
355 
	    R_GlobalContext->callflag = CTXT_GENERIC;
 338 
	    R_GlobalContext->callflag = CTXT_GENERIC;
356 
	    *ans = applyMethod(t, sxp, matchedarg, rho, newrho);
 339 
	    *ans = applyMethod(t, sxp, matchedarg, rho, newrho);
357 
	    R_GlobalContext->callflag = CTXT_RETURN;
 340 
	    R_GlobalContext->callflag = CTXT_RETURN;
Line 843... Line 826...
843 
    }
 826 
    }
844 
    return CAR(args);
 827 
    return CAR(args);
845 
}
 828 
}
846 
 
 829 
 
847 
static SEXP s_S4inherits;
 830 
static SEXP s_S4inherits;
848 
static SEXP do_S4inherits(SEXP obj, SEXP what, SEXP which) {
 - 
 
849 
    SEXP e, val;
 - 
 
850 
    if(!s_S4inherits)
 - 
 
851 
      s_S4inherits = install(".S4inherits");
 - 
 
852 
    PROTECT(e = allocVector(LANGSXP, 4));
 - 
 
853 
    SETCAR(e, s_S4inherits);
 - 
 
854 
    val = CDR(e);
 - 
 
855 
    SETCAR(val, obj);
 - 
 
856 
    val = CDR(val);
 - 
 
857 
    SETCAR(val, what);
 - 
 
858 
    val = CDR(val);
 - 
 
859 
    SETCAR(val, which);
 - 
 
860 
    val = eval(e, R_MethodsNamespace);
 - 
 
861 
    UNPROTECT(1);
 - 
 
862 
    return val;
 - 
 
863 
}
 - 
 
864 
 
 - 
 
865 
 
 831 
 
866 
SEXP attribute_hidden do_inherits(SEXP call, SEXP op, SEXP args, SEXP env)
 832 
SEXP attribute_hidden do_inherits(SEXP call, SEXP op, SEXP args, SEXP env)
867 
{
 833 
{
868 
    SEXP x, klass, what, which, rval = R_NilValue /* -Wall */;
 834 
    SEXP x, klass, what, which, rval = R_NilValue /* -Wall */;
869 
    int i, j, nwhat, isvec, nclass;
 835 
    int i, j, nwhat, isvec, nclass;
870 
 
 836 
 
871 
    checkArity(op, args);
 837 
    checkArity(op, args);
872 
 
 838 
 
873 
    x = CAR(args);
 839 
    x = CAR(args);
874 
    if(IS_S4_OBJECT(x))
 840 
    if(IS_S4_OBJECT(x))
875 
      return do_S4inherits(x, CADR(args), CADDR(args));
 841 
	PROTECT(klass = R_data_class2(x));
876 
    else
 842 
    else
877 
      PROTECT(klass = R_data_class(x, FALSE));
 843 
	PROTECT(klass = R_data_class(x, FALSE));
878 
    nclass = length(klass);
 844 
    nclass = length(klass);
879 
 
 845 
 
880 
    what = CADR(args);
 846 
    what = CADR(args);
881 
    if(!isString(what))
 847 
    if(!isString(what))
882 
	error(_("'what' must be a character vector"));
 848 
	error(_("'what' must be a character vector"));