C++ checkArity函数代码示例

SEXP attribute_hidden do_relop(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans;

    if (DispatchGroup("Ops", call, op, args, env, &ans))
	return ans;
    checkArity(op, args);
    return do_relop_dflt(call, op, CAR(args), CADR(args));
}

SEXP do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP prompt, onMouseDown, onMouseMove, onMouseUp, onKeybd;
    GEDevDesc *dd;
    NewDevDesc *nd;
    
    checkArity(op, args);
    
    dd = GEcurrentDevice();
    nd = dd->dev;
    
    if (!nd->newDevStruct || !nd->getEvent) 
    	errorcall(call, _("graphics device does not support graphics events"));
    
    prompt = CAR(args);
    if (!isString(prompt)) errorcall(call, _("invalid prompt"));
    args = CDR(args);
    
    onMouseDown = CAR(args);
    if (TYPEOF(onMouseDown) == NILSXP) onMouseDown = NULL;
    else if (!nd->canGenMouseDown)
	errorcall(call, _("'onMouseDown' not supported"));
    else if (TYPEOF(onMouseDown) != CLOSXP || 
	     TYPEOF(onMouseDown) != RCC_CLOSXP) 
	errorcall(call, _("invalid 'onMouseDown' callback"));
    args = CDR(args);
    
    onMouseMove = CAR(args);
    if (TYPEOF(onMouseMove) == NILSXP) onMouseMove = NULL;
    else if (!nd->canGenMouseMove) 
	errorcall(call, _("'onMouseMove' not supported"));
    else if (TYPEOF(onMouseMove) != CLOSXP ||
	     TYPEOF(onMouseDown) != RCC_CLOSXP) 
	errorcall(call, _("invalid 'onMouseMove' callback"));
    args = CDR(args);
    
    onMouseUp = CAR(args);
    if (TYPEOF(onMouseUp) == NILSXP) onMouseUp = NULL;
    else if (!nd->canGenMouseUp) 
	errorcall(call, _("'onMouseUp' not supported"));
    else if (TYPEOF(onMouseUp) != CLOSXP ||
	     TYPEOF(onMouseDown) != RCC_CLOSXP) 
	errorcall(call, _("invalid 'onMouseUp' callback"));
    args = CDR(args);
    
    onKeybd = CAR(args);
    if (TYPEOF(onKeybd) == NILSXP) onKeybd = NULL;
    else if (!nd->canGenKeybd) 
	errorcall(call, _("'onKeybd' not supported"));
    else if (TYPEOF(onKeybd) != CLOSXP ||
	     TYPEOF(onMouseDown) != RCC_CLOSXP) 
	errorcall(call, _("invalid 'onKeybd' callback"));
    
    /* NB:  cleanup of event handlers must be done by driver in onExit handler */
    
    return(nd->getEvent(env, CHAR(STRING_ELT(prompt,0))));
}

/* R function  qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP x, sx;
    int indx_ret, n;
    double *vx = NULL;
    int *ivx = NULL;
    Rboolean x_real, x_int;

    checkArity(op, args);
    x = CAR(args);
    if (!isNumeric(x))
	error(_("argument is not a numeric vector"));
    x_real= TYPEOF(x) == REALSXP;
    x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
    PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
    SET_ATTRIB(sx, R_NilValue);
    SET_OBJECT(sx, 0);
    /* if x has names, drop them, since they won't be ordered
       if (!isNull(getAttrib(sx, R_NamesSymbol)))
	   setAttrib(sx, R_NamesSymbol, R_NilValue); */
    indx_ret = asLogical(CADR(args));
    n = LENGTH(x);
    if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
    if(indx_ret) {
	SEXP ans, ansnames, indx;
	int i, *ix;
	/* answer will have x = sorted x , ix = index :*/
	PROTECT(ans      = allocVector(VECSXP, 2));
	PROTECT(ansnames = allocVector(STRSXP, 2));
	PROTECT(indx = allocVector(INTSXP, n));
	ix = INTEGER(indx);
	for(i = 0; i < n; i++)
	    ix[i] = i+1;

	if(x_int)
	    R_qsort_int_I(ivx, ix, 1, n);
	else
	    R_qsort_I(vx, ix, 1, n);

	SET_VECTOR_ELT(ans, 0, sx);
	SET_VECTOR_ELT(ans, 1, indx);
	SET_STRING_ELT(ansnames, 0, mkChar("x"));
	SET_STRING_ELT(ansnames, 1, mkChar("ix"));
	setAttrib(ans, R_NamesSymbol, ansnames);
	UNPROTECT(4);
	return ans;
    }
    else {
	if(x_int)
	    R_qsort_int(ivx, 1, n);
	else
	    R_qsort(vx, 1, n);

	UNPROTECT(1);
	return sx;
    }
}

SEXP attribute_hidden
do_getNumRtoCConverters(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans;
    checkArity(op, args);
    ans = allocVector(INTSXP, 1);
    INTEGER(ans)[0] = Rf_getNumRtoCConverters();
    return(ans);
}

SEXP attribute_hidden do_envir(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    if (TYPEOF(CAR(args)) == CLOSXP)
	return CLOENV(CAR(args));
    else if (CAR(args) == R_NilValue)
	return R_GlobalContext->sysparent;
    else return getAttrib(CAR(args), R_DotEnvSymbol);
}

SEXP do_cum(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP s, t, ans;
    int i;
    checkArity(op, args);
    if (DispatchGroup("Math", call, op, args, env, &ans))
	return ans;
    if (isComplex(CAR(args))) {
	t = CAR(args);
	s = allocVector(CPLXSXP, LENGTH(t));
	setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
	for (i = 0 ; i < length(t) ; i++) {
	    COMPLEX(s)[i].r = NA_REAL;
	    COMPLEX(s)[i].i = NA_REAL;
	}
	switch (PRIMVAL(op) ) {
	case 1:	/* cumsum */
	    return ccumsum(t, s);
	    break;
	case 2: /* cumprod */
	    return ccumprod(t, s);
	    break;
	case 3: /* cummax */
	case 4: /* cummin */
	    errorcall(call, _("min/max not defined for complex numbers"));
	    break;
	default:
	    errorcall(call, _("unknown cumxxx function"));
	}
    }
    else { /* Non-Complex:  here, (sh|c)ould differentiate  real / int */
	PROTECT(t = coerceVector(CAR(args), REALSXP));
	s = allocVector(REALSXP, LENGTH(t));
	setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol));
	for(i = 0 ; i < length(t) ; i++)
	    REAL(s)[i] = NA_REAL;
	UNPROTECT(1);
	switch (PRIMVAL(op) ) {
	case 1:	/* cumsum */
	    return cumsum(t,s);
	    break;
	case 2: /* cumprod */
	    return cumprod(t,s);
	    break;
	case 3: /* cummax */
	    return cummax(t,s);
	    break;
	case 4: /* cummin */
	    return cummin(t,s);
	    break;
	default:
	    errorcall(call, _("unknown cumxxx function"));
	}
    }
    return R_NilValue; /* for -Wall */
}

/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP in = CAR(args), out = CADR(args);
    SET_ATTRIB(out, ATTRIB(in));
    IS_S4_OBJECT(in) ?  SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
    SET_OBJECT(out, OBJECT(in));
    return out;
}

SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    if (isFactor(CAR(args)) && isFactor(CADR(args))) {
	if (length(CAR(args)) != length(CADR(args)))
	    errorcall(call, _("unequal factor lengths"));
	return(cross(CAR(args), CADR(args)));
    }
    return seq(call, CAR(args), CADR(args));
}

/* This is a special .Internal, so has unevaluated arguments.  It is
   called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP R_fcall, ans, names, X, XX, FUN;
    R_xlen_t i, n;
    PROTECT_INDEX px;

    checkArity(op, args);
    PROTECT_WITH_INDEX(X = CAR(args), &px);
    PROTECT(XX = eval(CAR(args), rho));
    FUN = CADR(args);  /* must be unevaluated for use in e.g. bquote */
    n = xlength(XX);
    if (n == NA_INTEGER) error(_("invalid length"));
    Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);

    PROTECT(ans = allocVector(VECSXP, n));
    names = getAttrib(XX, R_NamesSymbol);
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);

    /* The R level code has ensured that XX is a vector.
       If it is atomic we can speed things up slightly by
       using the evaluated version.
    */
    {
	SEXP ind, tmp;
	/* Build call: FUN(XX[[<ind>]], ...) */

	/* Notice that it is OK to have one arg to LCONS do memory
	   allocation and not PROTECT the result (LCONS does memory
	   protection of its args internally), but not both of them,
	   since the computation of one may destroy the other */

	PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
	if(isVectorAtomic(XX))
	    PROTECT(tmp = LCONS(R_Bracket2Symbol,
				CONS(XX, CONS(ind, R_NilValue))));
	else
	    PROTECT(tmp = LCONS(R_Bracket2Symbol,
				CONS(X, CONS(ind, R_NilValue))));
	PROTECT(R_fcall = LCONS(FUN,
				CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));

	for(i = 0; i < n; i++) {
	    if (realIndx) REAL(ind)[0] = double(i + 1);
	    else INTEGER(ind)[0] = int(i + 1);
	    tmp = eval(R_fcall, rho);
	    if (NAMED(tmp))
		tmp = duplicate(tmp);
	    SET_VECTOR_ELT(ans, i, tmp);
	}
	UNPROTECT(3);
    }

    UNPROTECT(3); /* X, XX, ans */
    return ans;
}

SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    SEXP s = CAR(args), ncopy = CADR(args);
    R_xlen_t nc;
    SEXP a;

    if (!isVector(ncopy))
	error(_("incorrect type for second argument"));

    if (!isVector(s) && s != R_NilValue)
	error(_("attempt to replicate an object of type '%s'"), 
	      type2char(TYPEOF(s)));

    nc = xlength(ncopy); // might be 0
    if (nc == xlength(s)) 
	PROTECT(a = rep2(s, ncopy));
    else {
	if (nc != 1) error(_("invalid '%s' value"), "times");
	
#ifdef LONG_VECTOR_SUPPORT
	double snc = asReal(ncopy);
	if (!R_FINITE(snc) || snc < 0)
	    error(_("invalid '%s' value"), "times");
	nc = (R_xlen_t) snc;
#else
	if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0)/* nc = 0 ok */
	    error(_("invalid '%s' value"), "times");
#endif
	R_xlen_t ns = xlength(s);
	PROTECT(a = rep3(s, ns, nc * ns));
    }

#ifdef _S4_rep_keepClass
    if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
	setAttrib(a, R_ClassSymbol, getClassAttrib(s));
	SET_S4_OBJECT(a);
    }
#endif

    if (inheritsCharSXP(s, R_FactorCharSXP)) {
	SEXP tmp;
	if(inheritsCharSXP(s, R_OrderedCharSXP)) {
	    PROTECT(tmp = allocVector(STRSXP, 2));
	    SET_STRING_ELT(tmp, 0, R_OrderedCharSXP);
	    SET_STRING_ELT(tmp, 1, R_FactorCharSXP);
	} else PROTECT(tmp = mkString("factor"));
	setAttrib(a, R_ClassSymbol, tmp);
	UNPROTECT(1);
	setAttrib(a, R_LevelsSymbol, getLevelsAttrib(s));
    }
    UNPROTECT(1);
    return a;
}

SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP file;

    checkArity(op, args);
    file = CAR(args);
    if (!isString(file) || length(file) != 1)
	errorcall(call, _("invalid '%s' argument"), "file");
    internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE);
    return R_NilValue;
}

SEXP attribute_hidden do_curlDownload(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    if(!initialized) internet_Init();
    if(initialized > 0)
	return (*ptr->curlDownload)(call, op, args, rho);
    else {
	error(_("internet routines cannot be loaded"));
	return R_NilValue;
    }
}

SEXP attribute_hidden do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP s;

    checkArity(op,args);
    if (TYPEOF(CAR(args)) == STRSXP && length(CAR(args))==1) {
	PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0)));
	SETCAR(args, findFun(s, rho));
	UNPROTECT(1);
    }

    if (TYPEOF(CAR(args)) == CLOSXP) {
	s = allocSExp(CLOSXP);
	SET_FORMALS(s, FORMALS(CAR(args)));
	SET_BODY(s, R_NilValue);
	SET_CLOENV(s, R_GlobalEnv);
	return s;
    }

    if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) {
	char *nm = PRIMNAME(CAR(args));
	SEXP env, s2;
	PROTECT_INDEX xp;

	PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv,
						 install(".ArgsEnv"), TRUE),
			   &xp);

	if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
	PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
	if(s2 != R_UnboundValue) {
	    s = duplicate(s2);
	    SET_CLOENV(s, R_GlobalEnv);
	    UNPROTECT(2);
	    return s;
	}
	UNPROTECT(1); /* s2 */
	REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"),
					TRUE), xp);
	if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
	PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
	if(s2 != R_UnboundValue) {
	    s = allocSExp(CLOSXP);
	    SET_FORMALS(s, FORMALS(s2));
	    SET_BODY(s, R_NilValue);
	    SET_CLOENV(s, R_GlobalEnv);
	    UNPROTECT(2);
	    return s;
	}
	UNPROTECT(2);
    }
    return R_NilValue;
}

SEXP do_invisible(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    switch (length(args)) {
    case 0:
	return R_NilValue;
    case 1:
	return CAR(args);
    default:
	checkArity(op, args);
	return call;/* never used, just for -Wall */
    }
}

SEXP attribute_hidden do_dynunload(SEXP call, SEXP op, SEXP args, SEXP env)
{
    char buf[2 * PATH_MAX];

    checkArity(op,args);
    if (!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
	error(_("character argument expected"));
    GetFullDLLPath(call, buf, translateChar(STRING_ELT(CAR(args), 0)));
    if(!DeleteDLL(buf))
	error(_("shared object '%s\' was not loaded"), buf);
    return R_NilValue;
}