Rcpp Version 0.12.12
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 namespace Rcpp { SEXP Rcpp_eval(SEXP, SEXP); }
32 
33 // [[Rcpp::register]]
34 SEXP get_string_elt(SEXP x, R_xlen_t i) {
35  return STRING_ELT(x, i);
36 }
37 
38 // [[Rcpp::register]]
39 const char* char_get_string_elt(SEXP x, R_xlen_t i) {
40  return CHAR(STRING_ELT(x, i));
41 }
42 
43 // [[Rcpp::register]]
44 void set_string_elt(SEXP x, R_xlen_t i, SEXP value) {
45  SET_STRING_ELT(x, i, value);
46 }
47 
48 // [[Rcpp::register]]
49 void char_set_string_elt(SEXP x, R_xlen_t i, const char* value) {
50  SET_STRING_ELT(x, i, Rf_mkChar(value));
51 }
52 
53 // [[Rcpp::register]]
54 SEXP* get_string_ptr(SEXP x) {
55  return STRING_PTR(x);
56 }
57 
58 // [[Rcpp::register]]
59 SEXP get_vector_elt(SEXP x, R_xlen_t i) {
60  return VECTOR_ELT(x, i);
61 }
62 
63 // [[Rcpp::register]]
64 void set_vector_elt(SEXP x, R_xlen_t i, SEXP value) {
65  SET_VECTOR_ELT(x, i, value);
66 }
67 
68 // [[Rcpp::register]]
69 SEXP* get_vector_ptr(SEXP x) {
70  return VECTOR_PTR(x);
71 }
72 
73 // [[Rcpp::register]]
74 void* dataptr(SEXP x) {
75  return DATAPTR(x);
76 }
77 
78 // [[Rcpp::register]]
79 const char* char_nocheck(SEXP x) {
80  return CHAR(x);
81 }
82 
83 static bool Rcpp_cache_know = false;
84 static SEXP Rcpp_cache = R_NilValue;
85 
86 #define RCPP_HASH_CACHE_INDEX 4
87 #define RCPP_CACHE_SIZE 5
88 
89 #ifndef RCPP_HASH_CACHE_INITIAL_SIZE
90 #define RCPP_HASH_CACHE_INITIAL_SIZE 1024
91 #endif
92 
93 // only used for debugging
95  if (! Rcpp_cache_know) {
96 
97  SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
98  Rcpp::Shield<SEXP> RcppString(Rf_mkString("Rcpp"));
99  Rcpp::Shield<SEXP> call(Rf_lang2(getNamespaceSym, RcppString));
100  Rcpp::Shield<SEXP> RCPP(Rcpp_eval(call, R_GlobalEnv));
101 
102  Rcpp_cache = Rf_findVarInFrame(RCPP, Rf_install(".rcpp_cache"));
103  Rcpp_cache_know = true;
104  }
105  return Rcpp_cache;
106 }
107 
108 namespace Rcpp {
109  namespace internal {
110  // [[Rcpp::register]]
111  SEXP get_Rcpp_namespace() {
112  return VECTOR_ELT(get_rcpp_cache() , 0);
113  }
114  }
115 }
116 
117 // [[Rcpp::register]]
119  return VECTOR_ELT(get_rcpp_cache(), 3);
120 }
121 
122 // [[Rcpp::register]]
123 SEXP rcpp_set_stack_trace(SEXP e) {
124  SET_VECTOR_ELT(get_rcpp_cache(), 3, e);
125  return R_NilValue;
126 }
127 
128 SEXP set_error_occured(SEXP cache, SEXP e) {
129  SET_VECTOR_ELT(cache, 1, e);
130  return R_NilValue;
131 }
132 
133 SEXP set_current_error(SEXP cache, SEXP e) {
134  SET_VECTOR_ELT(cache, 2, e);
135  return R_NilValue;
136 }
137 
139  SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
140  Rcpp::Shield<SEXP> RcppString(Rf_mkString("Rcpp"));
141  Rcpp::Shield<SEXP> call(Rf_lang2(getNamespaceSym, RcppString));
142  Rcpp::Shield<SEXP> RCPP(Rcpp_eval(call, R_GlobalEnv));
143  Rcpp::Shield<SEXP> cache(Rf_allocVector(VECSXP, RCPP_CACHE_SIZE));
144 
145  // the Rcpp namespace
146  SET_VECTOR_ELT(cache, 0, RCPP);
147  set_error_occured(cache, Rf_ScalarLogical(FALSE)); // error occured
148  set_current_error(cache, R_NilValue); // current error
149  SET_VECTOR_ELT(cache, 3, R_NilValue); // stack trace
150  Rcpp::Shield<SEXP> tmp(Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE));
151  SET_VECTOR_ELT(cache, RCPP_HASH_CACHE_INDEX, tmp);
152  Rf_defineVar(Rf_install(".rcpp_cache"), cache, RCPP);
153 
154  return cache;
155 }
156 
157 // [[Rcpp::register]]
159  SEXP cache = get_rcpp_cache();
160 
161  // error occured
162  set_error_occured(cache, Rf_ScalarLogical(FALSE));
163 
164  // current error
165  set_current_error(cache, R_NilValue);
166 
167  // stack trace
168  SET_VECTOR_ELT(cache, 3, R_NilValue);
169 
170  return R_NilValue;
171 }
172 
173 // [[Rcpp::register]]
175  SEXP err = VECTOR_ELT(get_rcpp_cache(), 1);
176  return LOGICAL(err)[0];
177 }
178 
179 // [[Rcpp::internal]]
180 SEXP rcpp_error_recorder(SEXP e) {
181  SEXP cache = get_rcpp_cache();
182 
183  // error occured
184  set_error_occured(cache, Rf_ScalarLogical(TRUE));
185 
186  // current error
187  set_current_error(cache, e);
188 
189  return R_NilValue;
190 }
191 
192 // [[Rcpp::register]]
194  return VECTOR_ELT(get_rcpp_cache(), 2);
195 }
196 
197 // [[Rcpp::register]]
198 int* get_cache(int m) {
199  SEXP cache = get_rcpp_cache();
200  SEXP hash_cache = VECTOR_ELT(cache, RCPP_HASH_CACHE_INDEX);
201  int n = Rf_length(hash_cache);
202  if (m > n) {
203  Rcpp::Shield<SEXP> new_hash_cache(Rf_allocVector(INTSXP, m));
204  hash_cache = new_hash_cache;
205  SET_VECTOR_ELT(cache,RCPP_HASH_CACHE_INDEX, hash_cache);
206  }
207  int *res = INTEGER(hash_cache);
208  std::fill(res, res+m, 0);
209  return res;
210 }
211 
SEXP set_error_occured(SEXP cache, SEXP e)
Definition: barrier.cpp:128
void set_string_elt(SEXP x, R_xlen_t i, SEXP value)
Definition: barrier.cpp:44
SEXP rcpp_set_stack_trace(SEXP e)
Definition: barrier.cpp:123
SEXP rcpp_get_current_error()
Definition: barrier.cpp:193
void char_set_string_elt(SEXP x, R_xlen_t i, const char *value)
Definition: barrier.cpp:49
const char * char_nocheck(SEXP x)
Definition: barrier.cpp:79
SEXP rcpp_error_recorder(SEXP e)
Definition: barrier.cpp:180
int * get_cache(int m)
Definition: barrier.cpp:198
SEXP rcpp_get_stack_trace()
Definition: barrier.cpp:118
SEXP get_rcpp_cache()
Definition: barrier.cpp:94
SEXP init_Rcpp_cache()
Definition: barrier.cpp:138
static SEXP Rcpp_cache
Definition: barrier.cpp:84
SEXP Rcpp_eval(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:25
SEXP get_string_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:34
void set_vector_elt(SEXP x, R_xlen_t i, SEXP value)
Definition: barrier.cpp:64
#define RCPP_CACHE_SIZE
Definition: barrier.cpp:87
#define RCPP_HASH_CACHE_INITIAL_SIZE
Definition: barrier.cpp:90
static bool Rcpp_cache_know
Definition: barrier.cpp:83
void * dataptr(SEXP x)
Definition: barrier.cpp:74
SEXP * get_vector_ptr(SEXP x)
Definition: barrier.cpp:69
const char * char_get_string_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:39
#define RCPP_HASH_CACHE_INDEX
Definition: barrier.cpp:86
SEXP * get_string_ptr(SEXP x)
Definition: barrier.cpp:54
SEXP set_current_error(SEXP cache, SEXP e)
Definition: barrier.cpp:133
attribute_hidden SEXP get_Rcpp_namespace()
Definition: routines.h:95
Rcpp API.
Definition: algo.h:28
SEXP reset_current_error()
Definition: barrier.cpp:158
SEXP get_vector_elt(SEXP x, R_xlen_t i)
Definition: barrier.cpp:59
int error_occured()
Definition: barrier.cpp:174