The R Project SVN R

Rev

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

Rev 52273 Rev 52431
Line 242... Line 242...
242 
    }
 242 
    }
243 
    if(s_S3table == R_UnboundValue)
 243 
    if(s_S3table == R_UnboundValue)
244 
      return FALSE; /* too screwed up to do conversions */
 244 
      return FALSE; /* too screwed up to do conversions */
245 
    return findVarInFrame3(s_S3table, install(ss), FALSE) != R_UnboundValue;
 245 
    return findVarInFrame3(s_S3table, install(ss), FALSE) != R_UnboundValue;
246 
}
 246 
}
247
247 
 
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, sort_list;
 253 
    SEXP klass, method, sxp, t, s, matchedarg, sort_list;
Line 370... Line 370...
370 
    return 0;
 370 
    return 0;
371 
}
 371 
}
372 
 
 372 
 
373 
/* Note: "do_usemethod" is not the only entry point to
 373 
/* Note: "do_usemethod" is not the only entry point to
374 
   "usemethod". Things like [ and [[ call usemethod directly,
 374 
   "usemethod". Things like [ and [[ call usemethod directly,
375 
   hence do_usemethod should just be an interface to usemethod.
375 
   hence do_usemethod should just be an interface to usemethod.
376 
*/
 376 
*/
377 
 
 377 
 
378 
/* This is a primitive SPECIALSXP */
 378 
/* This is a primitive SPECIALSXP */
379 
SEXP attribute_hidden do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
 379 
SEXP attribute_hidden do_usemethod(SEXP call, SEXP op, SEXP args, SEXP env)
380 
{
 380 
{
Line 386... Line 386...
386 
    PROTECT(ap = list2(R_NilValue, R_NilValue));
 386 
    PROTECT(ap = list2(R_NilValue, R_NilValue));
387 
    SET_TAG(ap,  install("generic"));
 387 
    SET_TAG(ap,  install("generic"));
388 
    SET_TAG(CDR(ap), install("object"));
 388 
    SET_TAG(CDR(ap), install("object"));
389 
    PROTECT(argList =  matchArgs(ap, args, call));
 389 
    PROTECT(argList =  matchArgs(ap, args, call));
390 
    if (CAR(argList) == R_MissingArg)
 390 
    if (CAR(argList) == R_MissingArg)
391 
	errorcall(call, _("there must be a 'generic' argument"));
391 
	errorcall(call, _("there must be a 'generic' argument"));
392 
    else
392 
    else
393 
	PROTECT(generic = eval(CAR(argList), env));
 393 
	PROTECT(generic = eval(CAR(argList), env));
394 
    if(!isString(generic) || length(generic) != 1)
 394 
    if(!isString(generic) || length(generic) != 1)
395 
	errorcall(call, _("'generic' argument must be a character string"));
 395 
	errorcall(call, _("'generic' argument must be a character string"));
396 
 
 396 
 
397 
 
 397 
 
Line 448... Line 448...
448 
	SEXP klass;
 448 
	SEXP klass;
449 
	int nclass;
 449 
	int nclass;
450 
	char cl[1000];
 450 
	char cl[1000];
451 
	PROTECT(klass = R_data_class2(obj));
 451 
	PROTECT(klass = R_data_class2(obj));
452 
	nclass = length(klass);
 452 
	nclass = length(klass);
453 
	if (nclass == 1)
453 
	if (nclass == 1)
454 
	    strcpy(cl, translateChar(STRING_ELT(klass, 0)));
 454 
	    strcpy(cl, translateChar(STRING_ELT(klass, 0)));
455 
	else {
 455 
	else {
456 
	    int i;
 456 
	    int i;
457 
	    strcpy(cl, "c('");
 457 
	    strcpy(cl, "c('");
458 
	    for (i = 0; i < nclass; i++) {
 458 
	    for (i = 0; i < nclass; i++) {
Line 825... Line 825...
825 
	setAttrib(CAR(args), R_ClassSymbol, R_NilValue);
 825 
	setAttrib(CAR(args), R_ClassSymbol, R_NilValue);
826 
    }
 826 
    }
827 
    return CAR(args);
 827 
    return CAR(args);
828 
}
 828 
}
829 
 
 829 
 
830 
/* static SEXP s_S4inherits; */
 - 
 
831 
 
 - 
 
832 
SEXP attribute_hidden do_inherits(SEXP call, SEXP op, SEXP args, SEXP env)
 - 
 
833 
{
 - 
 
834 
    SEXP x, klass, what, which, rval = R_NilValue /* -Wall */;
 - 
 
835 
    int i, j, nwhat, isvec, nclass;
 - 
 
836 
 
 830 
 
837 
    checkArity(op, args);
 - 
 
838 
 
 831 
 
- 
 
 832 
/* NOTE: Fast  inherits(x, what)    in ../include/Rinlinedfuns.h
- 
 
 833 
 * ----        ----------------- */
- 
 
 834 
/** C API for  R  inherits(x, what, which)
- 
 
 835 
 *
839 
    x = CAR(args);
 836 
 * @param x any R object
- 
 
 837 
 * @param what character vector
- 
 
 838 
 * @param which logical: "want vector result" ?
- 
 
 839 
 *
- 
 
 840 
 * @return if which is false, logical TRUE or FALSE
- 
 
 841 
 *	   if which is true, integer vector of length(what) ..
- 
 
 842 
 */
- 
 
 843 
SEXP inherits3(SEXP x, SEXP what, SEXP which)
- 
 
 844 
{
- 
 
 845 
    SEXP klass, rval = R_NilValue /* -Wall */;
840 
    if(IS_S4_OBJECT(x))
 846 
    if(IS_S4_OBJECT(x))
841 
	PROTECT(klass = R_data_class2(x));
 847 
	PROTECT(klass = R_data_class2(x));
842 
    else
 848 
    else
843 
	PROTECT(klass = R_data_class(x, FALSE));
 849 
	PROTECT(klass = R_data_class(x, FALSE));
844 
    nclass = length(klass);
 850 
    int nclass = length(klass);
845 
 
 851 
 
846 
    what = CADR(args);
 - 
 
847 
    if(!isString(what))
 852 
    if(!isString(what))
848 
	error(_("'what' must be a character vector"));
 853 
	error(_("'what' must be a character vector"));
849 
    nwhat = length(what);
 854 
    int j, nwhat = length(what);
850 
 
 855 
 
851 
    which = CADDR(args);
 - 
 
852 
    if( !isLogical(which) || (length(which) != 1) )
 856 
    if( !isLogical(which) || (length(which) != 1) )
853 
	error(_("'which' must be a length 1 logical vector"));
 857 
	error(_("'which' must be a length 1 logical vector"));
854 
    isvec = asLogical(which);
 858 
    int isvec = asLogical(which);
855 
 
 859 
 
856 
#ifdef _be_too_picky_
 860 
#ifdef _be_too_picky_
857 
    if(IS_S4_OBJECT(x) && nwhat == 1 && !isvec &&
 861 
    if(IS_S4_OBJECT(x) && nwhat == 1 && !isvec &&
858 
       !isNull(R_getClassDef(translateChar(STRING_ELT(what, 0)))))
 862 
       !isNull(R_getClassDef(translateChar(STRING_ELT(what, 0)))))
859 
	warning(_("use 'is()' instead of 'inherits()' on S4 objects"));
 863 
	warning(_("use 'is()' instead of 'inherits()' on S4 objects"));
Line 861... Line 865...
861 
 
 865 
 
862 
    if(isvec)
 866 
    if(isvec)
863 
	PROTECT(rval = allocVector(INTSXP, nwhat));
 867 
	PROTECT(rval = allocVector(INTSXP, nwhat));
864 
 
 868 
 
865 
    for(j = 0; j < nwhat; j++) {
 869 
    for(j = 0; j < nwhat; j++) {
866 
	const char *ss = translateChar(STRING_ELT(what, j));
 870 
	const char *ss = translateChar(STRING_ELT(what, j)); int i;
- 
 
 871 
	if(isvec)
- 
 
 872 
	    INTEGER(rval)[j] = 0;
867 
	for(i = 0; i < nclass; i++) {
 873 
	for(i = 0; i < nclass; i++) {
868 
	    if(isvec)
 - 
 
869 
		INTEGER(rval)[j] = 0;
 - 
 
870 
	    if(!strcmp(translateChar(STRING_ELT(klass, i)), ss)) {
 874 
	    if(!strcmp(translateChar(STRING_ELT(klass, i)), ss)) {
871 
		if(isvec)
 875 
		if(isvec)
872 
		   INTEGER(rval)[j] = i+1;
 876 
		    INTEGER(rval)[j] = i+1;
873 
		else {
 877 
		else {
874 
		    UNPROTECT(1);
 878 
		    UNPROTECT(1);
875 
		    return mkTrue();
 879 
		    return mkTrue();
876 
		}
 880 
		}
877 
		break;
 881 
		break;
Line 884... Line 888...
884 
    }
 888 
    }
885 
    UNPROTECT(2);
 889 
    UNPROTECT(2);
886 
    return rval;
 890 
    return rval;
887 
}
 891 
}
888 
 
 892 
 
- 
 
 893 
SEXP attribute_hidden do_inherits(SEXP call, SEXP op, SEXP args, SEXP env)
- 
 
 894 
{
- 
 
 895 
    checkArity(op, args);
- 
 
 896 
 
- 
 
 897 
    return inherits3(/* x = */ CAR(args),
- 
 
 898 
		     /* what = */ CADR(args),
- 
 
 899 
		     /* which = */ CADDR(args));
- 
 
 900 
}
- 
 
 901 
 
889 
 
 902 
 
890 
/*
 903 
/*
891 
   ==============================================================
 904 
   ==============================================================
892 
 
 905 
 
893 
     code from here on down is support for the methods package
 906 
     code from here on down is support for the methods package