static SEXP _top_prenv(SEXP promise, SEXP env) { while(TYPEOF(promise) == PROMSXP) { env = PRENV(promise); promise = PREXPR(promise); } return env; }
SEXP _dots_expressions(SEXP dots) { SEXP names, s, expressions; int i, length; if ((TYPEOF(dots) == VECSXP) && (LENGTH(dots) == 0)) return R_NilValue; else if ((TYPEOF(dots) != DOTSXP) && (TYPEOF(dots) != LISTSXP)) error("Expected dotlist or pairlist, got %d", TYPEOF(dots)); names = PROTECT(_dots_names(dots)); length = _dots_length(dots); PROTECT(expressions = allocVector(VECSXP, length)); for (s = dots, i = 0; i < length; s = CDR(s), i++) { SEXP item = CAR(s); // if we have an unevluated promise whose code is another promise, descend while ((PRENV(item) != R_NilValue) && (TYPEOF(PRCODE(item)) == PROMSXP)) { item = PRCODE(item); } SET_VECTOR_ELT(expressions, i, PREXPR(item)); } if (names != R_NilValue) setAttrib(expressions, R_NamesSymbol, names); UNPROTECT(2); return(expressions); }
// [[Rcpp::export]] SEXP make_lazy(SEXP name, SEXP env, SEXP follow_symbols_) { SEXP promise = findVar(name, env); int follow_symbols = asLogical(follow_symbols_); // recurse until we find the real promise, not a promise of a promise while(TYPEOF(promise) == PROMSXP) { env = PRENV(promise); promise = PREXPR(promise); // If the promise is threaded through multiple functions, we'll // get some symbols along the way. If the symbol is bound to a promise // keep going on up if (follow_symbols && TYPEOF(promise) == SYMSXP) { SEXP obj = findVar(promise, env); if (TYPEOF(obj) == PROMSXP) { promise = obj; } } } // Make named list for output SEXP lazy = PROTECT(allocVector(VECSXP, 2)); SET_VECTOR_ELT(lazy, 0, promise); SET_VECTOR_ELT(lazy, 1, env); SEXP names = PROTECT(allocVector(STRSXP, 2)); SET_STRING_ELT(names, 0, mkChar("expr")); SET_STRING_ELT(names, 1, mkChar("env")); setAttrib(lazy, install("names"), names); setAttrib(lazy, install("class"), PROTECT(mkString("lazy"))); UNPROTECT(3); return lazy; }
SEXP _dots_unpack(SEXP dots) { int i; SEXP s; int length = 0; SEXP names, environments, expressions, values; //SEXP evaluated, codeptr, missing, wraplist; //SEXP seen; SEXP dataFrame; SEXP colNames; //check inputs and measure length length = _dots_length(dots); // unpack information for each item: // names, environemnts, expressions, values, evaluated, seen PROTECT(names = allocVector(STRSXP, length)); PROTECT(environments = allocVector(VECSXP, length)); PROTECT(expressions = allocVector(VECSXP, length)); PROTECT(values = allocVector(VECSXP, length)); for (s = dots, i = 0; i < length; s = CDR(s), i++) { if (TYPEOF(s) != DOTSXP && TYPEOF(s) != LISTSXP) error("Expected dotlist or pairlist, got %s at index %d", type2char(TYPEOF(s)), i); SEXP item = CAR(s); if (item == R_MissingArg) item = emptypromise(); if (TYPEOF(item) != PROMSXP) error("Expected PROMSXP as CAR of DOTSXP, got %s", type2char(TYPEOF(item))); // if we have an unevluated promise whose code is another promise, descend while ((PRENV(item) != R_NilValue) && (TYPEOF(PRCODE(item)) == PROMSXP)) { item = PRCODE(item); } if ((TYPEOF(PRENV(item)) != ENVSXP) && (PRENV(item) != R_NilValue)) error("Expected ENVSXP or NULL in environment slot of DOTSXP, got %s", type2char(TYPEOF(item))); SET_VECTOR_ELT(environments, i, PRENV(item)); SET_VECTOR_ELT(expressions, i, PREXPR(item)); SET_STRING_ELT(names, i, isNull(TAG(s)) ? R_BlankString : PRINTNAME(TAG(s))); if (PRVALUE(item) != R_UnboundValue) { SET_VECTOR_ELT(values, i, PRVALUE(item)); } else { SET_VECTOR_ELT(values, i, R_NilValue); } } PROTECT(dataFrame = allocVector(VECSXP, 4)); SET_VECTOR_ELT(dataFrame, 0, names); SET_VECTOR_ELT(dataFrame, 1, environments); SET_VECTOR_ELT(dataFrame, 2, expressions); SET_VECTOR_ELT(dataFrame, 3, values); PROTECT(colNames = allocVector(STRSXP, 4)); SET_STRING_ELT(colNames, 0, mkChar("name")); SET_STRING_ELT(colNames, 1, mkChar("envir")); SET_STRING_ELT(colNames, 2, mkChar("expr")); SET_STRING_ELT(colNames, 3, mkChar("value")); setAttrib(dataFrame, R_NamesSymbol, colNames); setAttrib(dataFrame, R_RowNamesSymbol, names); setAttrib(dataFrame, R_ClassSymbol, ScalarString(mkChar("data.frame"))); UNPROTECT(6); return(dataFrame); }
SEXP attribute_hidden matchPositionalArgsCreateEnv(SEXP formals, SEXP *supplied, int nsupplied, SEXP call, SEXP rho, SEXP* outActuals) { SEXP *s; SEXP f, a; SEXP actuals = R_NilValue; SEXP newrho = PROTECT(NewEnvironmentNR(rho)); SEXP *endSupplied = supplied + nsupplied; for (f = formals, s = supplied, a = actuals ; f != R_NilValue ; f = CDR(f), s++) { if (TAG(f) == R_DotsSymbol) { /* pack all remaining arguments into ... */ SEXP *rs = endSupplied - 1; SEXP dotsContent = R_NilValue; for(; rs >= s; rs--) { dotsContent = CONS(*rs, dotsContent); /* FIXME: enabling refcnt? */ } SEXP dots = CONS_NR(dotsContent, R_NilValue); SET_TAG(dots, R_DotsSymbol); if (dotsContent != R_NilValue) { SET_TYPEOF(dotsContent, DOTSXP); } else { SET_MISSING(dots, 1); } if (a == R_NilValue) { PROTECT(actuals = dots); } else { SETCDR(a, dots); ENABLE_REFCNT(a); /* dots are part of a protected list */ } a = dots; f = CDR(f); s = endSupplied; /* falls through into noMoreSupplied branch below */ } if (s == endSupplied) { /* possibly fewer supplied arguments than formals */ SEXP ds; for(; f != R_NilValue ; f = CDR(f), a = ds) { ds = CONS_NR(R_MissingArg, R_NilValue); SET_TAG(ds, TAG(f)); if (a == R_NilValue) { PROTECT(actuals = ds); } else { SETCDR(a, ds); ENABLE_REFCNT(a); /* ds is part of a protected list */ } SEXP fdefault = CAR(f); if (fdefault != R_MissingArg) { SET_MISSING(ds, 2); SETCAR(ds, mkPROMISEorConst(fdefault, newrho)); } else { SET_MISSING(ds, 1); } } break; } /* normal case, the next supplied arg is available */ SEXP arg = CONS_NR(*s, R_NilValue); SET_TAG(arg, TAG(f)); if (a == R_NilValue) { PROTECT(actuals = arg); } else { SETCDR(a, arg); ENABLE_REFCNT(a); } a = arg; } if (s < endSupplied) { /* some arguments are not used */ SEXP *rs = endSupplied - 1; SEXP unusedForError = R_NilValue; for(; rs >= s; rs--) { SEXP rsValue = *rs; if (TYPEOF(rsValue) == PROMSXP) { rsValue = PREXPR(rsValue); } unusedForError = CONS(rsValue, unusedForError); } PROTECT(unusedForError); /* needed? */ errorcall(call /* R_GlobalContext->call */, ngettext("unused argument %s", "unused arguments %s", (unsigned long) length(unusedForError)), CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4); /* '+ 4' is to remove 'list' from 'list(badTag1,...)' */ UNPROTECT(1); } if (a != R_NilValue) { ENABLE_REFCNT(a); } SET_FRAME(newrho, actuals); ENABLE_REFCNT(newrho); UNPROTECT(1); /* newrho */ if (actuals != R_NilValue) { UNPROTECT(1); /* actuals */ } *outActuals = actuals; return(newrho); }
SEXP attribute_hidden matchUnnamedArgsCreateEnv(SEXP formals, SEXP supplied, SEXP call, SEXP rho, SEXP* outActuals) { SEXP f, s; SEXP actuals = PROTECT(supplied); SEXP newrho = PROTECT(NewEnvironmentNR(rho)); SEXP prevS = R_NilValue; for (f = formals, s = supplied ; f != R_NilValue ; f = CDR(f), prevS = s, s = CDR(s)) { if (TAG(f) == R_DotsSymbol) { /* pack all arguments into ... */ SEXP dots = CONS_NR(R_MissingArg, R_NilValue); SET_TAG(dots, R_DotsSymbol); if (prevS == R_NilValue) { UNPROTECT(1); /* old actuals */ PROTECT(actuals = dots); } else { SETCDR(prevS, dots); ENABLE_REFCNT(prevS); /* dots are part of a protected list */ } if (s != R_NilValue) { SET_TYPEOF(s, DOTSXP); SETCAR(dots, s); s = R_NilValue; } else { SET_MISSING(dots, 1); } prevS = dots; f = CDR(f); /* falls through into s == R_NilValue case */ } if (s == R_NilValue) { /* fewer supplied arguments than formals */ SEXP ds; for(; f != R_NilValue ; f = CDR(f), prevS = ds) { ds = CONS_NR(R_MissingArg, R_NilValue); SET_TAG(ds, TAG(f)); if (prevS == R_NilValue) { UNPROTECT(1); /* old actuals */ PROTECT(actuals = ds); } else { SETCDR(prevS, ds); ENABLE_REFCNT(prevS); /* ds is part of a protected list */ } SEXP fdefault = CAR(f); if (fdefault != R_MissingArg) { SET_MISSING(ds, 2); SETCAR(ds, mkPROMISEorConst(fdefault, newrho)); } else { SET_MISSING(ds, 1); } } break; } /* normal case, the next supplied arg is available */ SET_TAG(s, TAG(f)); if (CAR(s) == R_MissingArg) { SEXP fdefault = CAR(f); if (fdefault != R_MissingArg) { SET_MISSING(s, 2); SETCAR(s, mkPROMISEorConst(fdefault, newrho)); } else { SET_MISSING(s, 1); } } if (prevS != R_NilValue) { ENABLE_REFCNT(prevS); } } if (s != R_NilValue) { /* some arguments are not used */ SEXP unusedForError = PROTECT(s); SETCDR(prevS, R_NilValue); /* make sure they're not in the new environment */ /* show bad arguments in call without evaluating them */ for (; s != R_NilValue; s = CDR(s)) { SEXP carS = CAR(s); if (TYPEOF(carS) == PROMSXP) { SETCAR(s, PREXPR(carS)); } } errorcall(call /* R_GlobalContext->call */, ngettext("unused argument %s", "unused arguments %s", (unsigned long) length(unusedForError)), CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4); /* '+ 4' is to remove 'list' from 'list(badTag1,...)' */ UNPROTECT(1); } if (prevS != R_NilValue) { ENABLE_REFCNT(prevS); } SET_FRAME(newrho, actuals); ENABLE_REFCNT(newrho); UNPROTECT(2); /* newrho, actuals */ *outActuals = actuals; return(newrho); }
SEXP attribute_hidden matchArgs(SEXP formals, SEXP supplied, SEXP call) { int i, seendots, arg_i = 0; SEXP f, a, b, dots, actuals; actuals = R_NilValue; for (f = formals ; f != R_NilValue ; f = CDR(f), arg_i++) { /* CONS_NR is used since argument lists created here are only used internally and so should not increment reference counts */ actuals = CONS_NR(R_MissingArg, actuals); SET_MISSING(actuals, 1); } /* We use fargused instead of ARGUSED/SET_ARGUSED on elements of formals to avoid modification of the formals SEXPs. A gc can cause matchArgs to be called from finalizer code, resulting in another matchArgs call with the same formals. In R-2.10.x, this corrupted the ARGUSED data of the formals and resulted in an incorrect "formal argument 'foo' matched by multiple actual arguments" error. */ int fargused[arg_i ? arg_i : 1]; // avoid undefined behaviour memset(fargused, 0, sizeof(fargused)); for(b = supplied; b != R_NilValue; b = CDR(b)) SET_ARGUSED(b, 0); PROTECT(actuals); /* First pass: exact matches by tag */ /* Grab matched arguments and check */ /* for multiple exact matches. */ f = formals; a = actuals; arg_i = 0; while (f != R_NilValue) { if (TAG(f) != R_DotsSymbol) { i = 1; for (b = supplied; b != R_NilValue; b = CDR(b)) { if (TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), 1)) { if (fargused[arg_i] == 2) error(_("formal argument \"%s\" matched by multiple actual arguments"), CHAR(PRINTNAME(TAG(f)))); if (ARGUSED(b) == 2) error(_("argument %d matches multiple formal arguments"), i); SETCAR(a, CAR(b)); if(CAR(b) != R_MissingArg) SET_MISSING(a, 0); SET_ARGUSED(b, 2); fargused[arg_i] = 2; } i++; } } f = CDR(f); a = CDR(a); arg_i++; } /* Second pass: partial matches based on tags */ /* An exact match is required after first ... */ /* The location of the first ... is saved in "dots" */ dots = R_NilValue; seendots = 0; f = formals; a = actuals; arg_i = 0; while (f != R_NilValue) { if (fargused[arg_i] == 0) { if (TAG(f) == R_DotsSymbol && !seendots) { /* Record where ... value goes */ dots = a; seendots = 1; } else { i = 1; for (b = supplied; b != R_NilValue; b = CDR(b)) { if (ARGUSED(b) != 2 && TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), seendots)) { if (ARGUSED(b)) error(_("argument %d matches multiple formal arguments"), i); if (fargused[arg_i] == 1) error(_("formal argument \"%s\" matched by multiple actual arguments"), CHAR(PRINTNAME(TAG(f)))); if (R_warn_partial_match_args) { warningcall(call, _("partial argument match of '%s' to '%s'"), CHAR(PRINTNAME(TAG(b))), CHAR(PRINTNAME(TAG(f))) ); } SETCAR(a, CAR(b)); if (CAR(b) != R_MissingArg) SET_MISSING(a, 0); SET_ARGUSED(b, 1); fargused[arg_i] = 1; } i++; } } } f = CDR(f); a = CDR(a); arg_i++; } /* Third pass: matches based on order */ /* All args specified in tag=value form */ /* have now been matched. If we find ... */ /* we gobble up all the remaining args. */ /* Otherwise we bind untagged values in */ /* order to any unmatched formals. */ f = formals; a = actuals; b = supplied; seendots = 0; while (f != R_NilValue && b != R_NilValue && !seendots) { if (TAG(f) == R_DotsSymbol) { /* Skip ... matching until all tags done */ seendots = 1; f = CDR(f); a = CDR(a); } else if (CAR(a) != R_MissingArg) { /* Already matched by tag */ /* skip to next formal */ f = CDR(f); a = CDR(a); } else if (ARGUSED(b) || TAG(b) != R_NilValue) { /* This value used or tagged , skip to next value */ /* The second test above is needed because we */ /* shouldn't consider tagged values for positional */ /* matches. */ /* The formal being considered remains the same */ b = CDR(b); } else { /* We have a positional match */ SETCAR(a, CAR(b)); if(CAR(b) != R_MissingArg) SET_MISSING(a, 0); SET_ARGUSED(b, 1); b = CDR(b); f = CDR(f); a = CDR(a); } } if (dots != R_NilValue) { /* Gobble up all unused actuals */ SET_MISSING(dots, 0); i = 0; for(a = supplied; a != R_NilValue ; a = CDR(a)) if(!ARGUSED(a)) i++; if (i) { a = allocList(i); SET_TYPEOF(a, DOTSXP); f = a; for(b = supplied; b != R_NilValue; b = CDR(b)) if(!ARGUSED(b)) { SETCAR(f, CAR(b)); SET_TAG(f, TAG(b)); f = CDR(f); } SETCAR(dots, a); } } else { /* Check that all arguments are used */ SEXP unused = R_NilValue, last = R_NilValue; for (b = supplied; b != R_NilValue; b = CDR(b)) if (!ARGUSED(b)) { if(last == R_NilValue) { PROTECT(unused = CONS(CAR(b), R_NilValue)); SET_TAG(unused, TAG(b)); last = unused; } else { SETCDR(last, CONS(CAR(b), R_NilValue)); last = CDR(last); SET_TAG(last, TAG(b)); } } if(last != R_NilValue) { /* show bad arguments in call without evaluating them */ SEXP unusedForError = R_NilValue, last = R_NilValue; for(b = unused ; b != R_NilValue ; b = CDR(b)) { SEXP tagB = TAG(b), carB = CAR(b) ; if (TYPEOF(carB) == PROMSXP) carB = PREXPR(carB) ; if (last == R_NilValue) { PROTECT(last = CONS(carB, R_NilValue)); SET_TAG(last, tagB); unusedForError = last; } else { SETCDR(last, CONS(carB, R_NilValue)); last = CDR(last); SET_TAG(last, tagB); } } errorcall(call /* R_GlobalContext->call */, ngettext("unused argument %s", "unused arguments %s", (unsigned long) length(unusedForError)), CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4); /* '+ 4' is to remove 'list' from 'list(badTag1,...)' */ } } UNPROTECT(1); return(actuals); }