/* This is a primitive SPECIALSXP */
SEXP attribute_hidden do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *ctxt;
SEXP code, oldcode, tmp, argList;
int addit = 0;
static SEXP do_onexit_formals = NULL;
if (do_onexit_formals == NULL)
do_onexit_formals = allocFormalsList2(install("expr"), install("add"));
PROTECT(argList = matchArgs(do_onexit_formals, args, call));
if (CAR(argList) == R_MissingArg) code = R_NilValue;
else code = CAR(argList);
if (CADR(argList) != R_MissingArg) {
addit = asLogical(eval(CADR(args), rho));
if (addit == NA_INTEGER)
errorcall(call, _("invalid '%s' argument"), "add");
}
ctxt = R_GlobalContext;
/* Search for the context to which the on.exit action is to be
attached. Lexical scoping is implemented by searching for the
first closure call context with an environment matching the
expression evaluation environment. */
while (ctxt != R_ToplevelContext &&
!((ctxt->callflag & CTXT_FUNCTION) && ctxt->cloenv == rho) )
ctxt = ctxt->nextcontext;
if (ctxt->callflag & CTXT_FUNCTION)
{
if (addit && (oldcode = ctxt->conexit) != R_NilValue ) {
if ( CAR(oldcode) != R_BraceSymbol )
{
PROTECT(tmp = allocList(3));
SETCAR(tmp, R_BraceSymbol);
SETCADR(tmp, oldcode);
SETCADDR(tmp, code);
SET_TYPEOF(tmp, LANGSXP);
ctxt->conexit = tmp;
UNPROTECT(1);
}
else
{
PROTECT(tmp = allocList(1));
SETCAR(tmp, code);
ctxt->conexit = listAppend(duplicate(oldcode),tmp);
UNPROTECT(1);
}
}
else
ctxt->conexit = code;
}
UNPROTECT(1);
return R_NilValue;
}
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object, previous, ans, argList;
char buffer[21];
static SEXP do_retracemem_formals = NULL;
if (do_retracemem_formals == NULL)
do_retracemem_formals = allocFormalsList2(install("x"),
R_PreviousSymbol);
PROTECT(argList = matchArgs(do_retracemem_formals, args, call));
if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue);
if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue);
object = CAR(argList);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
previous = CADR(argList);
if(!isNull(previous) && !isString(previous))
errorcall(call, _("invalid '%s' argument"), "previous");
if (RTRACE(object)) {
snprintf(buffer, 21, "<%p>", (void *) object);
ans = mkString(buffer);
} else {
R_Visible = 0;
ans = R_NilValue;
}
if (previous != R_NilValue){
SET_RTRACE(object, 1);
if (R_current_trace_state()) {
/* FIXME: previous will have <0x....> whereas other values are
without the < > */
Rprintf("tracemem[%s -> %p]: ",
translateChar(STRING_ELT(previous, 0)), (void *) object);
memtrace_stack_dump();
}
}
UNPROTECT(1);
return ans;
#else
R_Visible = 0; /* for consistency with other case */
return R_NilValue;
#endif
}
