The R Project SVN – R – Diff – /trunk/src/main/debug.c



/*
 *  R : A Computer Langage for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1998-2013   The R Core Team.
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.

 
SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
    SEXP object;
    char buffer[21];
 
    checkArity(op, args);
    check1arg(args, call, "x");
 
    object = CAR(args);

    if(TYPEOF(object) == EXTPTRSXP || TYPEOF(object) == WEAKREFSXP)
	errorcall(call,
		  _("'tracemem' is not useful for weak reference or external pointer objects"));
 
    SET_RTRACE(object, 1);
    snprintf(buffer, 21, "<%p>", (void *) object);
    return mkString(buffer);
#else
    errorcall(call, _("R was not compiled with support for memory profiling"));
    return R_NilValue;
#endif

 
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
    SEXP object, previous, ans, ap, argList;
    char buffer[21];
 
    PROTECT(ap = list2(R_NilValue, R_NilValue));
    SET_TAG(ap,  install("x"));
    SET_TAG(CDR(ap), install("previous"));
    PROTECT(argList =  matchArgs(ap, args, call));

    previous = CADR(ap);
    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;
    }

Rev 63223	Rev 63692
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Langage for Statistical Data Analysis`	2	`* R : A Computer Langage for Statistical Data Analysis`
3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
4	`* Copyright (C) 1998-2012 The R Core Team.`	4	`* Copyright (C) 1998-2013 The R Core Team.`
5	`*`	5	`*`
6	`* This program is free software; you can redistribute it and/or modify`	6	`* This program is free software; you can redistribute it and/or modify`
7	`* it under the terms of the GNU General Public License as published by`	7	`* it under the terms of the GNU General Public License as published by`
8	`* the Free Software Foundation; either version 2 of the License, or`	8	`* the Free Software Foundation; either version 2 of the License, or`
9	`* (at your option) any later version.`	9	`* (at your option) any later version.`
Line 118...	Line 118...
118		118
119	`SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)`	119	`SEXP attribute_hidden do_tracemem(SEXP call, SEXP op, SEXP args, SEXP rho)`
120	`{`	120	`{`
121	`#ifdef R_MEMORY_PROFILING`	121	`#ifdef R_MEMORY_PROFILING`
122	`SEXP object;`	122	`SEXP object;`
123	`char buffer[20];`	123	`char buffer[21];`
124		124
125	`checkArity(op, args);`	125	`checkArity(op, args);`
126	`check1arg(args, call, "x");`	126	`check1arg(args, call, "x");`
127		127
128	`object = CAR(args);`	128	`object = CAR(args);`
Line 140...	Line 140...
140	`if(TYPEOF(object) == EXTPTRSXP \|\| TYPEOF(object) == WEAKREFSXP)`	140	`if(TYPEOF(object) == EXTPTRSXP \|\| TYPEOF(object) == WEAKREFSXP)`
141	`errorcall(call,`	141	`errorcall(call,`
142	`_("'tracemem' is not useful for weak reference or external pointer objects"));`	142	`_("'tracemem' is not useful for weak reference or external pointer objects"));`
143		143
144	`SET_RTRACE(object, 1);`	144	`SET_RTRACE(object, 1);`
145	`snprintf(buffer, 20, "<%p>", (void *) object);`	145	`snprintf(buffer, 21, "<%p>", (void *) object);`
146	`return mkString(buffer);`	146	`return mkString(buffer);`
147	`#else`	147	`#else`
148	`errorcall(call, _("R was not compiled with support for memory profiling"));`	148	`errorcall(call, _("R was not compiled with support for memory profiling"));`
149	`return R_NilValue;`	149	`return R_NilValue;`
150	`#endif`	150	`#endif`
Line 206...	Line 206...
206		206
207	`SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)`	207	`SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)`
208	`{`	208	`{`
209	`#ifdef R_MEMORY_PROFILING`	209	`#ifdef R_MEMORY_PROFILING`
210	`SEXP object, previous, ans, ap, argList;`	210	`SEXP object, previous, ans, ap, argList;`
211	`char buffer[20];`	211	`char buffer[21];`
212		212
213	`PROTECT(ap = list2(R_NilValue, R_NilValue));`	213	`PROTECT(ap = list2(R_NilValue, R_NilValue));`
214	`SET_TAG(ap, install("x"));`	214	`SET_TAG(ap, install("x"));`
215	`SET_TAG(CDR(ap), install("previous"));`	215	`SET_TAG(CDR(ap), install("previous"));`
216	`PROTECT(argList = matchArgs(ap, args, call));`	216	`PROTECT(argList = matchArgs(ap, args, call));`
Line 226...	Line 226...
226	`previous = CADR(ap);`	226	`previous = CADR(ap);`
227	`if(!isNull(previous) && !isString(previous))`	227	`if(!isNull(previous) && !isString(previous))`
228	`errorcall(call, _("invalid '%s' argument"), "previous");`	228	`errorcall(call, _("invalid '%s' argument"), "previous");`
229		229
230	`if (RTRACE(object)) {`	230	`if (RTRACE(object)) {`
231	`snprintf(buffer, 20, "<%p>", (void *) object);`	231	`snprintf(buffer, 21, "<%p>", (void *) object);`
232	`ans = mkString(buffer);`	232	`ans = mkString(buffer);`
233	`} else {`	233	`} else {`
234	`R_Visible = 0;`	234	`R_Visible = 0;`
235	`ans = R_NilValue;`	235	`ans = R_NilValue;`
236	`}`	236	`}`

The R Project SVN R

(root)/trunk/src/main/debug.c @ 63243 – Rev 63223 → 63692