The R Project SVN R

Rev

Rev 66330 | Rev 67181 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 66330 Rev 66751
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-2013   The R Core Team.
 4 
 *  Copyright (C) 1998-2014   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 38... Line 38...
38 
	SETCAR(args, findFun(s, rho));				\
 38 
	SETCAR(args, findFun(s, rho));				\
39 
	UNPROTECT(1);						\
 39 
	UNPROTECT(1);						\
40 
    }
 40 
    }
41 
    find_char_fun
 41 
    find_char_fun
42 
 
 42 
 
43 
    if (TYPEOF(CAR(args)) != CLOSXP && TYPEOF(CAR(args)) != SPECIALSXP
43 
    if (TYPEOF(CAR(args)) != CLOSXP && TYPEOF(CAR(args)) != SPECIALSXP
44 
         &&  TYPEOF(CAR(args)) != BUILTINSXP )
 44 
         &&  TYPEOF(CAR(args)) != BUILTINSXP )
45 
	errorcall(call, _("argument must be a closure"));
 45 
	errorcall(call, _("argument must be a closure"));
46 
    switch(PRIMVAL(op)) {
 46 
    switch(PRIMVAL(op)) {
47 
    case 0:
 47 
    case 0: // debug()
48 
	SET_RDEBUG(CAR(args), 1);
 48 
	SET_RDEBUG(CAR(args), 1);
49 
	break;
 49 
	break;
50 
    case 1:
 50 
    case 1: // undebug()
51 
	if( RDEBUG(CAR(args)) != 1 )
 51 
	if( RDEBUG(CAR(args)) != 1 )
52 
	    warningcall(call, "argument is not being debugged");
 52 
	    warningcall(call, "argument is not being debugged");
53 
	SET_RDEBUG(CAR(args), 0);
 53 
	SET_RDEBUG(CAR(args), 0);
54 
	break;
 54 
	break;
55 
    case 2:
 55 
    case 2: // isdebugged()
56 
        ans = ScalarLogical(RDEBUG(CAR(args)));
 56 
        ans = ScalarLogical(RDEBUG(CAR(args)));
57 
        break;
 57 
        break;
58 
    case 3:
 58 
    case 3: // debugonce()
59 
        SET_RSTEP(CAR(args), 1);
 59 
        SET_RSTEP(CAR(args), 1);
60 
        break;
 60 
        break;
61 
    }
 61 
    }
62 
    return ans;
 62 
    return ans;
63 
}
 63 
}
Line 85... Line 85...
85 
    }
 85 
    }
86 
    return R_NilValue;
 86 
    return R_NilValue;
87 
}
 87 
}
88 
 
 88 
 
89 
 
 89 
 
90 
/* maintain global trace state */
 90 
/* maintain global trace & debug state */
91 
 
 91 
 
92 
static Rboolean tracing_state = TRUE;
 92 
static Rboolean tracing_state = TRUE, debugging_state = TRUE;
93 
#define GET_TRACE_STATE tracing_state
 93 
#define GET_TRACE_STATE tracing_state
- 
 
 94 
#define GET_DEBUG_STATE debugging_state
94 
#define SET_TRACE_STATE(value) tracing_state = value
 95 
#define SET_TRACE_STATE(value) tracing_state = value
- 
 
 96 
#define SET_DEBUG_STATE(value) debugging_state = value
95 
 
 97 
 
96 
SEXP attribute_hidden do_traceOnOff(SEXP call, SEXP op, SEXP args, SEXP rho)
 98 
SEXP attribute_hidden do_traceOnOff(SEXP call, SEXP op, SEXP args, SEXP rho)
97 
{
 99 
{
98 
    checkArity(op, args);
 100 
    checkArity(op, args);
99 
    SEXP onOff = CAR(args);
 101 
    SEXP onOff = CAR(args);
- 
 
 102 
    Rboolean trace = (PRIMVAL(op) == 0),
- 
 
 103 
	prev = trace ? GET_TRACE_STATE : GET_DEBUG_STATE;
100 
 
 104 
 
101 
    Rboolean prev = GET_TRACE_STATE;
 - 
 
102 
    if(length(onOff) > 0) {
 105 
    if(length(onOff) > 0) {
103 
	Rboolean _new = asLogical(onOff);
 106 
	Rboolean _new = asLogical(onOff);
104 
	if(_new == TRUE || _new == FALSE)
 107 
	if(_new == TRUE || _new == FALSE)
105 
	    SET_TRACE_STATE(_new);
 108 
	    if(trace) SET_TRACE_STATE(_new);
- 
 
 109 
	    else      SET_DEBUG_STATE(_new);
106 
	else
 110 
	else
107 
	    error("Value for tracingState must be TRUE or FALSE");
 111 
	    error(_("Value for '%s' must be TRUE or FALSE"),
- 
 
 112 
		  trace ? "tracingState" : "debuggingState");
108 
    }
 113 
    }
109 
    return ScalarLogical(prev);
 114 
    return ScalarLogical(prev);
110 
}
 115 
}
111 
 
 116 
 
112 
Rboolean attribute_hidden
 117 
// GUIs, packages, etc can query:
- 
 
 118 
Rboolean R_current_debug_state() { return GET_DEBUG_STATE; }
113 
R_current_trace_state() { return GET_TRACE_STATE; }
 119 
Rboolean R_current_trace_state() { return GET_TRACE_STATE; }
114 
 
 120 
 
115 
 
 121 
 
116 
/* memory tracing */
 122 
/* memory tracing */
117 
/* report when a traced object is duplicated */
 123 
/* report when a traced object is duplicated */
118 
 
 124