The R Project SVN R

Rev

Rev 10172 | Rev 36990 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
2 
 *  R : A Computer Langage for Statistical Data Analysis
3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
7886 ripley 4 
 *  Copyright (C) 1998-2000   The R Development Core Team.
2 r 5 
 *
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
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
17 
 *  along with this program; if not, write to the Free Software
5458 ripley 18 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
2 r 19 
 */
5458 ripley 20 
 
5187 hornik 21 
#ifdef HAVE_CONFIG_H
7701 hornik 22 
#include <config.h>
5187 hornik 23 
#endif
2 r 24 
 
25 
#include "Defn.h"
26 
 
27 
SEXP do_debug(SEXP call, SEXP op, SEXP args, SEXP rho)
28 
{
1839 ihaka 29 
    checkArity(op,args);
6098 pd 30 
#define find_char_fun \
31 
    if (isValidString(CAR(args))) {				\
32 
	SEXP s;							\
10172 luke 33 
	PROTECT(s = install(CHAR(STRING_ELT(CAR(args), 0))));	\
34 
	SETCAR(args, findFun(s, rho));				\
6098 pd 35 
	UNPROTECT(1);						\
1839 ihaka 36 
    }
6098 pd 37 
    find_char_fun
38 
 
1839 ihaka 39 
    if (TYPEOF(CAR(args)) != CLOSXP)
5731 ripley 40 
	errorcall(call, "argument must be a function");
1839 ihaka 41 
    switch(PRIMVAL(op)) {
42 
    case 0:
10172 luke 43 
	SET_DEBUG(CAR(args), 1);
1839 ihaka 44 
	break;
45 
    case 1:
4247 rgentlem 46 
	if( DEBUG(CAR(args)) != 1 )
47 
	    warningcall(call, "argument is not being debugged");
10172 luke 48 
	SET_DEBUG(CAR(args), 0);
1839 ihaka 49 
	break;
50 
    }
51 
    return R_NilValue;
2 r 52 
}
53 
 
6098 pd 54 
SEXP do_trace(SEXP call, SEXP op, SEXP args, SEXP rho)
2 r 55 
{
1839 ihaka 56 
    checkArity(op, args);
6098 pd 57 
 
58 
    find_char_fun
59 
 
1895 ihaka 60 
    if (TYPEOF(CAR(args)) != CLOSXP &&
61 
	TYPEOF(CAR(args)) != BUILTINSXP &&
6098 pd 62 
	TYPEOF(CAR(args)) != SPECIALSXP)
6191 maechler 63 
	    errorcall(call, "argument must be a function");
1895 ihaka 64 
 
1839 ihaka 65 
    switch(PRIMVAL(op)) {
66 
    case 0:
10172 luke 67 
	SET_TRACE(CAR(args), 1);
1839 ihaka 68 
	break;
69 
    case 1:
10172 luke 70 
	SET_TRACE(CAR(args), 0);
1839 ihaka 71 
	break;
72 
    }
73 
    return R_NilValue;
2 r 74 
}
21102 jmc 75 
 
76 
 
77 
/* maintain global trace state */
78 
 
79 
static Rboolean tracing_state = TRUE;
80 
#define GET_TRACE_STATE tracing_state
81 
#define SET_TRACE_STATE(value) tracing_state = value
82 
 
83 
SEXP R_traceOnOff(SEXP onOff) {
84 
    SEXP value;
85 
    Rboolean prev = GET_TRACE_STATE;
86 
    if(length(onOff) > 0) {
87 
        Rboolean new = asLogical(onOff);
88 
        if(new == TRUE || new == FALSE)
89 
            SET_TRACE_STATE(new);
90 
        else
91 
            error("Value for tracingState must be TRUE or FALSE");
92 
    }
93 
    value = allocVector(LGLSXP, 1);
94 
    LOGICAL(value)[0] = prev;
95 
    return value;
96 
}
97 
 
98 
Rboolean R_current_trace_state() { return GET_TRACE_STATE; }