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 */ }
SEXP attribute_hidden do_cum(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP s, t, ans; R_xlen_t i, n; checkArity(op, args); if (DispatchGroup("Math", call, op, args, env, &ans)) return ans; if (isComplex(CAR(args))) { t = CAR(args); n = XLENGTH(t); PROTECT(s = allocVector(CPLXSXP, n)); setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol)); UNPROTECT(1); if(n == 0) return s; for (i = 0 ; i < n ; 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 */ errorcall(call, _("'cummax' not defined for complex numbers")); break; case 4: /* cummin */ errorcall(call, _("'cummin' not defined for complex numbers")); break; default: errorcall(call, "unknown cumxxx function"); } } else if( ( isInteger(CAR(args)) || isLogical(CAR(args)) ) && PRIMVAL(op) != 2) { PROTECT(t = coerceVector(CAR(args), INTSXP)); n = XLENGTH(t); PROTECT(s = allocVector(INTSXP, n)); setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol)); if(n == 0) { UNPROTECT(2); /* t, s */ return s; } for(i = 0 ; i < n ; i++) INTEGER(s)[i] = NA_INTEGER; switch (PRIMVAL(op) ) { case 1: /* cumsum */ ans = icumsum(t,s); break; case 3: /* cummax */ ans = icummax(t,s); break; case 4: /* cummin */ ans = icummin(t,s); break; default: errorcall(call, _("unknown cumxxx function")); ans = R_NilValue; } UNPROTECT(2); /* t, s */ return ans; } else { PROTECT(t = coerceVector(CAR(args), REALSXP)); n = XLENGTH(t); PROTECT(s = allocVector(REALSXP, n)); setAttrib(s, R_NamesSymbol, getAttrib(t, R_NamesSymbol)); UNPROTECT(2); if(n == 0) return s; for(i = 0 ; i < n ; i++) REAL(s)[i] = NA_REAL; 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 */ }