Rcpp Version 0.12.12
Environment.h
Go to the documentation of this file.
1 // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
2 //
3 // Environment.h: Rcpp R/C++ interface class library -- access R environments
4 //
5 // Copyright (C) 2009 - 2013 Dirk Eddelbuettel and Romain Francois
6 // Copyright (C) 2014 Dirk Eddelbuettel, Romain Francois and Kevin Ushey
7 //
8 // This file is part of Rcpp.
9 //
10 // Rcpp is free software: you can redistribute it and/or modify it
11 // under the terms of the GNU General Public License as published by
12 // the Free Software Foundation, either version 2 of the License, or
13 // (at your option) any later version.
14 //
15 // Rcpp is distributed in the hope that it will be useful, but
16 // WITHOUT ANY WARRANTY; without even the implied warranty of
17 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 // GNU General Public License for more details.
19 //
20 // You should have received a copy of the GNU General Public License
21 // along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
22 
23 #ifndef Rcpp_Environment_h
24 #define Rcpp_Environment_h
25 
26 // From 'R/Defn.h'
27 // NOTE: can't include header directly as it checks for some C99 features
28 extern "C" SEXP R_NewHashedEnv(SEXP, SEXP);
29 
30 namespace Rcpp{
31 
33  public BindingPolicy< Environment_Impl<StoragePolicy> >
34  {
35  private:
36  inline SEXP as_environment(SEXP x){
37  if( Rf_isEnvironment(x) ) return x ;
38  SEXP asEnvironmentSym = Rf_install("as.environment");
39  try {
40  Shield<SEXP> res( Rcpp_eval( Rf_lang2( asEnvironmentSym, x ) ) );
41  return res ;
42  } catch( const eval_error& ex) {
43  const char* fmt = "Cannot convert object to an environment: "
44  "[type=%s; target=ENVSXP].";
45  throw not_compatible(fmt, Rf_type2char(TYPEOF(x)));
46  }
47  }
48 
49  public:
51 
53  Storage::set__(R_GlobalEnv) ;
54  } ;
55 
61  Environment_Impl(SEXP x) {
62  Shield<SEXP> env(as_environment(x));
63  Storage::set__(env) ;
64  }
65 
71  Environment_Impl( const std::string& name ) ;
72 
79  Environment_Impl( int pos ) ;
80 
89  SEXP ls(bool all) const {
90  SEXP env = Storage::get__() ;
91  if( is_user_database() ){
92  R_ObjectTable *tb = (R_ObjectTable*) R_ExternalPtrAddr(HASHTAB(env));
93  return tb->objects(tb) ;
94  } else {
95  return R_lsInternal( env, all ? TRUE : FALSE ) ;
96  }
97  return R_NilValue ;
98  }
99 
107  SEXP get(const std::string& name) const {
108  SEXP env = Storage::get__() ;
109  SEXP nameSym = Rf_install(name.c_str());
110  SEXP res = Rf_findVarInFrame( env, nameSym ) ;
111 
112  if( res == R_UnboundValue ) return R_NilValue ;
113 
114  /* We need to evaluate if it is a promise */
115  if( TYPEOF(res) == PROMSXP){
116  res = Rf_eval( res, env ) ;
117  }
118  return res ;
119  }
120 
128  SEXP get(Symbol name) const {
129  SEXP env = Storage::get__() ;
130  SEXP res = Rf_findVarInFrame( env, name ) ;
131 
132  if( res == R_UnboundValue ) return R_NilValue ;
133 
134  /* We need to evaluate if it is a promise */
135  if( TYPEOF(res) == PROMSXP){
136  res = Rf_eval( res, env ) ;
137  }
138  return res ;
139  }
140 
141 
149  SEXP find( const std::string& name) const{
150  SEXP env = Storage::get__() ;
151  SEXP nameSym = Rf_install(name.c_str());
152  SEXP res = Rf_findVar( nameSym, env ) ;
153 
154  if( res == R_UnboundValue ) throw binding_not_found(name) ;
155 
156  /* We need to evaluate if it is a promise */
157  if( TYPEOF(res) == PROMSXP){
158  res = Rf_eval( res, env ) ;
159  }
160  return res ;
161  }
162 
169  SEXP find(Symbol name) const{
170  SEXP env = Storage::get__() ;
171  SEXP res = Rf_findVar( name, env ) ;
172 
173  if( res == R_UnboundValue ) {
174  // Pass on the const char* to the RCPP_EXCEPTION_CLASS's
175  // const std::string& requirement
176  throw binding_not_found(name.c_str()) ;
177  }
178 
179  /* We need to evaluate if it is a promise */
180  if( TYPEOF(res) == PROMSXP){
181  res = Rf_eval( res, env ) ;
182  }
183  return res ;
184  }
185 
194  bool exists( const std::string& name ) const {
195  SEXP nameSym = Rf_install(name.c_str());
196  SEXP res = Rf_findVarInFrame( Storage::get__() , nameSym ) ;
197  return res != R_UnboundValue ;
198  }
199 
211  bool assign( const std::string& name, SEXP x ) const{
212  if( exists( name) && bindingIsLocked(name) ) throw binding_is_locked(name) ;
213  SEXP nameSym = Rf_install(name.c_str());
214  Rf_defineVar( nameSym, x, Storage::get__() );
215  return true ;
216  }
217 
226  template <typename WRAPPABLE>
227  bool assign( const std::string& name, const WRAPPABLE& x) const ;
228 
233  bool isLocked() const {
234  return R_EnvironmentIsLocked(Storage::get__());
235  }
236 
240  bool remove( const std::string& name ){
241  if( exists(name) ){
242  if( bindingIsLocked(name) ){
243  throw binding_is_locked(name) ;
244  } else{
245  /* unless we want to copy all of do_remove,
246  we have to go back to R to do this operation */
247  SEXP internalSym = Rf_install( ".Internal" );
248  SEXP removeSym = Rf_install( "remove" );
249  Shield<SEXP> call( Rf_lang2(internalSym,
250  Rf_lang4(removeSym, Rf_mkString(name.c_str()), Storage::get__(), Rf_ScalarLogical( FALSE ))
251  ) );
252  Rcpp_eval( call, R_GlobalEnv ) ;
253  }
254  } else{
255  throw no_such_binding(name) ;
256  }
257  return true;
258  }
259 
265  void lock(bool bindings = false) {
266  R_LockEnvironment( Storage::get__(), bindings ? TRUE: FALSE ) ;
267  }
268 
275  void lockBinding(const std::string& name){
276  if( !exists( name) ) throw no_such_binding(name) ;
277  SEXP nameSym = Rf_install(name.c_str());
278  R_LockBinding( nameSym, Storage::get__() );
279  }
280 
287  void unlockBinding(const std::string& name){
288  if( !exists( name) ) throw no_such_binding(name) ;
289  SEXP nameSym = Rf_install(name.c_str());
290  R_unLockBinding( nameSym, Storage::get__() );
291  }
292 
301  bool bindingIsLocked(const std::string& name) const{
302  if( !exists( name) ) throw no_such_binding(name) ;
303  SEXP nameSym = Rf_install(name.c_str());
304  return R_BindingIsLocked(nameSym, Storage::get__() ) ;
305  }
306 
316  bool bindingIsActive(const std::string& name) const {
317  if( !exists( name) ) throw no_such_binding(name) ;
318  SEXP nameSym = Rf_install(name.c_str());
319  return R_BindingIsActive(nameSym, Storage::get__()) ;
320  }
321 
325  bool is_user_database() const {
326  SEXP env = Storage::get__() ;
327  return OBJECT(env) && Rf_inherits(env, "UserDefinedDatabase") ;
328  }
329 
334  return R_GlobalEnv ;
335  }
336 
341  return R_EmptyEnv ;
342  }
343 
348  return R_BaseEnv ;
349  }
350 
355  return R_BaseNamespace ;
356  }
357 
363  }
364 
372  static Environment_Impl namespace_env(const std::string& package){
373  Armor<SEXP> env ;
374  try{
375  SEXP getNamespaceSym = Rf_install("getNamespace");
376  Shield<SEXP> package_str( Rf_mkString(package.c_str()) );
377  env = Rcpp_eval( Rf_lang2(getNamespaceSym, package_str) ) ;
378  } catch( ... ){
379  throw no_such_namespace( package ) ;
380  }
381  return Environment_Impl( env ) ;
382  }
383 
388  return Environment_Impl( ENCLOS(Storage::get__()) ) ;
389  }
390 
395  SEXP newEnvSym = Rf_install("new.env");
396  return Environment_Impl( Rcpp_eval(Rf_lang3( newEnvSym, Rf_ScalarLogical(hashed), Storage::get__() )) );
397  }
398 
399 
400  void update(SEXP){}
401  };
402 
403 typedef Environment_Impl<PreserveStorage> Environment ;
404 
405 inline Environment new_env(int size = 29) {
406  Shield<SEXP> sizeSEXP(Rf_ScalarInteger(size));
407  return R_NewHashedEnv(R_EmptyEnv, sizeSEXP);
408 }
409 
410 inline Environment new_env(SEXP parent, int size = 29) {
411  Shield<SEXP> sizeSEXP(Rf_ScalarInteger(size));
412  Shield<SEXP> parentSEXP(parent);
413  if (!Rf_isEnvironment(parentSEXP)) {
414  stop("parent is not an environment");
415  }
416  return R_NewHashedEnv(parentSEXP, sizeSEXP);
417 }
418 
419 
420 } // namespace Rcpp
421 
422 #endif
SEXP ls(bool all) const
Definition: Environment.h:89
Environment new_env(int size=29)
Definition: Environment.h:405
bool exists(const std::string &name) const
Definition: Environment.h:194
static Environment_Impl empty_env()
Definition: Environment.h:340
#define RCPP_GENERATE_CTOR_ASSIGN(__CLASS__)
Definition: interface.h:21
void lock(bool bindings=false)
Definition: Environment.h:265
bool bindingIsLocked(const std::string &name) const
Definition: Environment.h:301
static Environment_Impl global_env()
Definition: Environment.h:333
Environment_Impl new_child(bool hashed)
Definition: Environment.h:394
SEXP Rcpp_eval(SEXP expr, SEXP env)
Definition: Rcpp_eval.h:25
SEXP R_NewHashedEnv(SEXP, SEXP)
SEXP find(const std::string &name) const
Definition: Environment.h:149
static Environment_Impl base_env()
Definition: Environment.h:347
RCPP_API_CLASS(DottedPair_Impl)
void lockBinding(const std::string &name)
Definition: Environment.h:275
sugar::All< NA, T > all(const Rcpp::VectorBase< LGLSXP, NA, T > &t)
Definition: all.h:84
Symbol_Impl< NoProtectStorage > Symbol
Definition: Symbol.h:82
bool isLocked() const
Definition: Environment.h:233
void unlockBinding(const std::string &name)
Definition: Environment.h:287
static Environment_Impl Rcpp_namespace()
Definition: Environment.h:361
void NORET stop(const char *fmt, Args &&...args)
Definition: exceptions.h:51
attribute_hidden SEXP get_Rcpp_namespace()
Definition: routines.h:95
static Environment_Impl base_namespace()
Definition: Environment.h:354
Rcpp API.
Definition: algo.h:28
Environment_Impl< PreserveStorage > Environment
Definition: Environment.h:401
bool is_user_database() const
Definition: Environment.h:325
bool bindingIsActive(const std::string &name) const
Definition: Environment.h:316
Environment_Impl parent() const
Definition: Environment.h:387
Environment_Impl(SEXP x)
Definition: Environment.h:61
void update(SEXP)
Definition: Environment.h:400
bool assign(const std::string &name, SEXP x) const
Definition: Environment.h:211
static Environment_Impl namespace_env(const std::string &package)
Definition: Environment.h:372