← Back to branch summary

~ubuntu-branches/ubuntu/maverick/rpy/maverick-updates

« back to all changes in this revision

Viewing changes to src/R_eval2091.c

  • Committer: Bazaar Package Importer
  • Author(s): Dirk Eddelbuettel
  • Date: 2009-07-09 10:41:45 UTC
  • mfrom: (6.1.2 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090709104145-v1qwmeoy2zkqsyd4
Tags: 1.0.3-8
* Rebuilt under R 2.9.1

* debian/control: Upgraded (Build-)Depends: to new R version

* debian/control: Upgraded Standards-Version: 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/R_eval2091.c
 
1
/*
 
2
 * $Id: R_eval.c 363 2007-11-12 23:27:48Z warnes $ 
 
3
 * Evaluation of R expressions.
 
4
 */
 
5
 
 
6
/* ***** BEGIN LICENSE BLOCK *****
 
7
 * Version: MPL 1.1/GPL 2.0/LGPL 2.1
 
8
 *
 
9
 * The contents of this file are subject to the Mozilla Public License Version
 
10
 * 1.1 (the "License"); you may not use this file except in compliance with
 
11
 * the License. You may obtain a copy of the License at
 
12
 * http://www.mozilla.org/MPL/
 
13
 *
 
14
 * Software distributed under the License is distributed on an "AS IS" basis,
 
15
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 
16
 * for the specific language governing rights and limitations under the
 
17
 * License.
 
18
 *
 
19
 * The Original Code is the RPy python module.
 
20
 *
 
21
 * The Initial Developer of the Original Code is Walter Moreira.
 
22
 * Portions created by the Initial Developer are Copyright (C) 2002
 
23
 * the Initial Developer. All Rights Reserved.
 
24
 *
 
25
 * Contributor(s):
 
26
 *    Gregory R. Warnes <greg@warnes.net> (Maintainer)
 
27
 *
 
28
 * Alternatively, the contents of this file may be used under the terms of
 
29
 * either the GNU General Public License Version 2 or later (the "GPL"), or
 
30
 * the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
 
31
 * in which case the provisions of the GPL or the LGPL are applicable instead
 
32
 * of those above. If you wish to allow use of your version of this file only
 
33
 * under the terms of either the GPL or the LGPL, and not to allow others to
 
34
 * use your version of this file under the terms of the MPL, indicate your
 
35
 * decision by deleting the provisions above and replace them with the notice
 
36
 * and other provisions required by the GPL or the LGPL. If you do not delete
 
37
 * the provisions above, a recipient may use your version of this file under
 
38
 * the terms of any one of the MPL, the GPL or the LGPL.
 
39
 *
 
40
 * ***** END LICENSE BLOCK ***** */
 
41
/*
 
42
 *  This program is free software; you can redistribute it and/or modify
 
43
 *  it under the terms of the GNU General Public License as published by
 
44
 *  the Free Software Foundation; either version 2 of the License, or
 
45
 *  (at your option) any later version.
 
46
 *
 
47
 *  This program is distributed in the hope that it will be useful,
 
48
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 
49
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
50
 *  GNU General Public License for more details.
 
51
 *
 
52
 *  You should have received a copy of the GNU General Public License
 
53
 *  along with this program; if not, write to the Free Software
 
54
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
55
 *
 
56
 *
 
57
 *  Evaluation of R expressions.
 
58
 *
 
59
 *  $Id: R_eval.c 363 2007-11-12 23:27:48Z warnes $
 
60
 *
 
61
 */
 
62
 
 
63
#include <RPy.h>
 
64
 
 
65
/* The Python original SIGINT handler */
 
66
PyOS_sighandler_t python_sigint;
 
67
 
 
68
/* Indicates whether the R interpreter was interrupted by a SIGINT */
 
69
int interrupted = 0;
 
70
 
 
71
/* Abort the current R computation due to a SIGINT */
 
72
void interrupt_R(int signum)
 
73
{
 
74
  interrupted = 1;
 
75
  error("Interrupted");
 
76
}
 
77
 
 
78
 
 
79
/* Evaluate a SEXP. It must be constructed by hand. It raises a Python
 
80
   exception if an error ocurred in the evaluation */
 
81
SEXP do_eval_expr(SEXP e) {
 
82
  SEXP res;
 
83
  int error = 0;
 
84
  PyOS_sighandler_t old_int;
 
85
 
 
86
  /* Enable our handler for SIGINT inside the R
 
87
     interpreter. Otherwise, we cannot stop R calculations, since
 
88
     SIGINT is only processed between Python bytecodes. Also, save the
 
89
     Python SIGINT handler because it is necessary to temporally
 
90
     restore it in user defined I/O Python functions. */
 
91
  stop_events();
 
92
 
 
93
  #ifdef _WIN32
 
94
    old_int = PyOS_getsig(SIGBREAK);
 
95
  #else
 
96
    old_int = PyOS_getsig(SIGINT);
 
97
  #endif
 
98
  python_sigint = old_int;
 
99
 
 
100
  signal(SIGINT, interrupt_R);
 
101
 
 
102
  interrupted = 0;
 
103
  res = R_tryEval(e, R_GlobalEnv, &error);
 
104
 
 
105
  #ifdef _WIN32
 
106
    PyOS_setsig(SIGBREAK, old_int);   
 
107
  #else 
 
108
    PyOS_setsig(SIGINT, old_int);
 
109
  #endif
 
110
 
 
111
  start_events();
 
112
 
 
113
  if (error) {
 
114
    if (interrupted) {
 
115
      PyErr_SetNone(PyExc_KeyboardInterrupt);
 
116
    }
 
117
    else
 
118
      PyErr_SetString(RPy_RException, get_last_error_msg());
 
119
    return NULL;
 
120
  }
 
121
 
 
122
 
 
123
  return res;
 
124
}
 
125
 
 
126
/* Evaluate a function given by a name (without arguments) */
 
127
SEXP do_eval_fun(char *name) {
 
128
  SEXP exp, fun, res;
 
129
 
 
130
  fun = get_fun_from_name(name);
 
131
  if (!fun)
 
132
    return NULL;
 
133
 
 
134
  PROTECT(fun);
 
135
  PROTECT(exp = allocVector(LANGSXP, 1));
 
136
  SETCAR(exp, fun);
 
137
 
 
138
  PROTECT(res = do_eval_expr(exp));
 
139
  UNPROTECT(3);
 
140
  return res;
 
141
}
 
142
 
 
143
/*
 
144
 * Get an R **function** object by its name. When not found, an exception is
 
145
 * raised. The checking of the length of the identifier is needed to
 
146
 * avoid R raising an error causing Python to  dump core.
 
147
 */
 
148
SEXP get_fun_from_name(char *ident) {
 
149
  SEXP obj;
 
150
 
 
151
  /* For R not to throw an error, we must check the identifier is
 
152
     neither null nor greater than MAXIDSIZE */
 
153
  if (!*ident) {
 
154
    PyErr_SetString(RPy_Exception, "attempt to use zero-length variable name");
 
155
    return NULL;
 
156
  }
 
157
  if (strlen(ident) > MAXIDSIZE) {
 
158
    PyErr_SetString(RPy_Exception, "symbol print-name too long");
 
159
    return NULL;
 
160
  }
 
161
  
 
162
#if R_VERSION < 0x20000
 
163
  obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
 
164
#else
 
165
  /*
 
166
   * For R-2.0.0 and later, it is necessary to use findFun to get
 
167
   * functions.  Unfortunately, calling findFun on an undefined name
 
168
   * causes a segfault!
 
169
   *
 
170
   * Solution:
 
171
   *
 
172
   * 1) Call findVar on the name
 
173
   *
 
174
   * 2) If something has the name, call findFun
 
175
   *
 
176
   * 3) Raise an error if either step 1 or 2 fails.
 
177
   */
 
178
  obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
 
179
 
 
180
  if (obj != R_UnboundValue)
 
181
      obj = Rf_findFun(Rf_install(ident), R_GlobalEnv);
 
182
#endif
 
183
  
 
184
  if (obj == R_UnboundValue) {
 
185
    PyErr_Format(RPy_Exception, "R Function \"%s\" not found", ident);
 
186
    return NULL;
 
187
  }
 
188
  return obj;
 
189
}
 
190
 
 
191
/* Obtain the text of the last R error message */
 
192
const char *get_last_error_msg() {
 
193
  SEXP msg;
 
194
 
 
195
  msg = do_eval_fun("geterrmessage");
 
196
  return CHARACTER_VALUE(msg);
 
197
}