Rcpp Version 1.0.0
barrier.cpp
Go to the documentation of this file.
1 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 4 -*-
2 //
3 // barrier.cpp: Rcpp R/C++ interface class library -- write barrier
4 //
5 // Copyright (C) 2010 - 2015 Dirk Eddelbuettel and Romain Francois
6 //
7 // This file is part of Rcpp.
8 //
9 // Rcpp is free software: you can redistribute it and/or modify it
10 // under the terms of the GNU General Public License as published by
11 // the Free Software Foundation, either version 2 of the License, or
12 // (at your option) any later version.
13 //
14 // Rcpp is distributed in the hope that it will be useful, but
15 // WITHOUT ANY WARRANTY; without even the implied warranty of
16 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 // GNU General Public License for more details.
18 //
19 // You should have received a copy of the GNU General Public License
20 // along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
21 
22 #define COMPILING_RCPP
23 
24 #define USE_RINTERNALS
25 #include <Rinternals.h>
26 #include <Rcpp/barrier.h>
27 #include "internal.h"
28 #include <algorithm>
29 #include <Rcpp/protection/Shield.h>
30 
31 // [[Rcpp::register]]
32 SEXP get_string_elt(SEXP x, R_xlen_t i) {
33  return STRING_ELT(x, i);
34 }
35 
36 // [[Rcpp::register]]
37 const char* char_get_string_elt(SEXP x, R_xlen_t i) {
38  return CHAR(STRING_ELT(x, i));
39 }
40 
41 // [[Rcpp::register]]
42 void set_string_elt(SEXP x, R_xlen_t i, SEXP value) {
43  SET_STRING_ELT(x, i, value);
44 }
45 
46 // [[Rcpp::register]]
47 void char_set_string_elt(SEXP x, R_xlen_t i, const char* value) {
48  SET_STRING_ELT(x, i, Rf_mkChar(value));
49 }
50 
51 // [[Rcpp::register]]
52 SEXP* get_string_ptr(SEXP x) {
53  return STRING_PTR(x);
54 }
55 
56 // [[Rcpp::register]]
57 SEXP get_vector_elt(SEXP x, R_xlen_t i) {
58  return VECTOR_ELT(x, i);
59 }
60 
61 // [[Rcpp::register]]
62 void set_vector_elt(SEXP x, R_xlen_t i, SEXP value) {
63  SET_VECTOR_ELT(x, i, value);
64 }
65 
66 // [[Rcpp::register]]
67 SEXP* get_vector_ptr(SEXP x) {
68  return VECTOR_PTR(x);
69 }
70 
71 // [[Rcpp::register]]
72 void* dataptr(SEXP x) {
73  return DATAPTR(x);
74 }
75 
76 // [[Rcpp::register]]
77 const char* char_nocheck(SEXP x) {
78  return CHAR(x);
79 }
80 
81 static bool Rcpp_cache_know = false;
82 static SEXP Rcpp_cache = R_NilValue;
83 
84 #define RCPP_HASH_CACHE_INDEX 4
85 #define RCPP_CACHE_SIZE 5
86 
87 #ifndef RCPP_HASH_CACHE_INITIAL_SIZE
88 #define RCPP_HASH_CACHE_INITIAL_SIZE 1024
89 #endif
90 
91 // only used for debugging
93  if (! Rcpp_cache_know) {
94 
95  SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
96  Rcpp::Shield<SEXP> RcppString(Rf_mkString("Rcpp"));
97  Rcpp::Shield<SEXP> call(Rf_lang2(getNamespaceSym, RcppString));
98  Rcpp::Shield<SEXP> RCPP(Rf_eval(call, R_GlobalEnv));
99 
100  Rcpp_cache = Rf_findVarInFrame(RCPP, Rf_install(".rcpp_cache"));
101  Rcpp_cache_know = true;
102  }
103  return Rcpp_cache;
104 }
105 
106 namespace Rcpp {
107  namespace internal {
108  // [[Rcpp::register]]
109  SEXP get_Rcpp_namespace() {
110  return VECTOR_ELT(get_rcpp_cache() , 0);
111  }
112  }
113 }
114 
115 // [[Rcpp::register]]
117  return VECTOR_ELT(get_rcpp_cache(), 3);
118 }
119 
120 // [[Rcpp::register]]
121 SEXP rcpp_set_stack_trace(SEXP e) {
122  SET_VECTOR_ELT(get_rcpp_cache(), 3, e);
123  return R_NilValue;
124 }
125 
126 SEXP set_error_occured(SEXP cache, SEXP e) {
127  SET_VECTOR_ELT(cache, 1, e);
128  return R_NilValue;
129 }
130 
131 SEXP set_current_error(SEXP cache, SEXP e) {
132  SET_VECTOR_ELT(cache, 2, e);
133  return R_NilValue;
134 }
135 
137  SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
138  Rcpp::Shield<SEXP> RcppString(Rf_mkString("Rcpp"));
139  Rcpp::Shield<SEXP> call(Rf_lang2(getNamespaceSym, RcppString));
140  Rcpp::Shield<SEXP> RCPP(Rf_eval(call, R_GlobalEnv));
141  Rcpp::Shield<SEXP> cache(Rf_allocVector(VECSXP, RCPP_CACHE_SIZE));
142 
143  // the Rcpp namespace
144  SET_VECTOR_ELT(cache, 0, RCPP);
145  set_error_occured(cache, Rf_ScalarLogical(FALSE)); // error occured
146  set_current_error(cache, R_NilValue); // current error
147  SET_VECTOR_ELT(cache, 3, R_NilValue); // stack trace
148  Rcpp::Shield<SEXP> tmp(Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE));
149  SET_VECTOR_ELT(cache, RCPP_HASH_CACHE_INDEX, tmp);
150  Rf_defineVar(Rf_install(".rcpp_cache"), cache, RCPP);
151 
152  return cache;
153 }
154 
155 // [[Rcpp::register]]
157  SEXP cache = get_rcpp_cache();
158 
159  // error occured
160  set_error_occured(cache, Rf_ScalarLogical(FALSE));
161 
162  // current error
163  set_current_error(cache, R_NilValue);
164 
165  // stack trace
166  SET_VECTOR_ELT(cache, 3, R_NilValue);
167 
168  return R_NilValue;
169 }
170 
171 // [[Rcpp::register]]
173  SEXP err = VECTOR_ELT(get_rcpp_cache(), 1);
174  return LOGICAL(err)[0];
175 }
176 
177 // [[Rcpp::internal]]
178 SEXP rcpp_error_recorder(SEXP e) {
179  SEXP cache = get_rcpp_cache();
180 
181  // error occured
182  set_error_occured(cache, Rf_ScalarLogical(TRUE));
183 
184  // current error
185  set_current_error(cache, e);
186 
187  return R_NilValue;
188 }
189 
190 // [[Rcpp::register]]
192  return VECTOR_ELT(get_rcpp_cache(), 2);
193 }
194 
195 // [[Rcpp::register]]
196 int* get_cache(int m) {
197  SEXP cache = get_rcpp_cache();
198  SEXP hash_cache = VECTOR_ELT(cache, RCPP_HASH_CACHE_INDEX);
199  int n = Rf_length(hash_cache);
200  if (m > n) {
201  Rcpp::Shield<SEXP> new_hash_cache(Rf_allocVector(INTSXP, m));
202  hash_cache = new_hash_cache;
203  SET_VECTOR_ELT(cache,RCPP_HASH_CACHE_INDEX, hash_cache);
204  }
205  int *res = INTEGER(hash_cache);
206  std::fill(res, res+m, 0);
207  return res;
208 }
209 
SEXP set_error_occured(SEXP cache, SEXP e)
Definition: barrier.cpp:126
void set_string_elt(SEXP x, R_xlen_t i, SEXP value)
Definition: barrier.cpp:42
SEXP rcpp_set_stack_trace(SEXP e)
Definition: barrier.cpp:121
SEXP rcpp_get_current_error()
Definition: barrier.cpp:191
void char_set_string_elt(SEXP x, R_xlen_t i, const char *value)
Definition: barrier.cpp:47
const char * char_nocheck(SEXP x)
Definition: barrier.cpp:77
SEXP rcpp_error_recorder(SEXP e)
Definition: barrier.cpp:178
int * get_cache(int m)
Definition: barrier.cpp:196
SEXP rcpp_get_stack_trace()
Definition: barrier.cpp:116
SEXP get_rcpp_cache()
Definition: barrier.cpp:92
SEXP init_Rcpp_cache()
Definition: barrier.cpp:136
static SEXP Rcpp_cache
Definition: barrier.cpp:82
SEXP get_string_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:32
void set_vector_elt(SEXP x, R_xlen_t i, SEXP value)
Definition: barrier.cpp:62
#define RCPP_CACHE_SIZE
Definition: barrier.cpp:85
#define RCPP_HASH_CACHE_INITIAL_SIZE
Definition: barrier.cpp:88
static bool Rcpp_cache_know
Definition: barrier.cpp:81
void * dataptr(SEXP x)
Definition: barrier.cpp:72
SEXP * get_vector_ptr(SEXP x)
Definition: barrier.cpp:67
const char * char_get_string_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:37
#define RCPP_HASH_CACHE_INDEX
Definition: barrier.cpp:84
SEXP * get_string_ptr(SEXP x)
Definition: barrier.cpp:52
SEXP set_current_error(SEXP cache, SEXP e)
Definition: barrier.cpp:131
attribute_hidden SEXP get_Rcpp_namespace()
Definition: routines.h:109
Rcpp API.
Definition: algo.h:28
SEXP reset_current_error()
Definition: barrier.cpp:156
SEXP get_vector_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:57
int error_occured()
Definition: barrier.cpp:172