as.h

Go to the documentation of this file.

// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*-
//
// as.h: Rcpp R/C++ interface class library -- convert SEXP to C++ objects
//
// Copyright (C) 2009 - 2013    Dirk Eddelbuettel and Romain Francois
// Copyright (C) 2013    Rice University
//
// This file is part of Rcpp.
//
// Rcpp is free software: you can redistribute it and/or modify it
// under the terms of the GNU General Public License as published by
// the Free Software Foundation, either version 2 of the License, or
// (at your option) any later version.
//
// Rcpp is distributed in the hope that it will be useful, but
// WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.

#ifndef Rcpp__as__h
#define Rcpp__as__h

#include <Rcpp/internal/Exporter.h>

namespace Rcpp{

    namespace internal{
        
        template <typename T> T primitive_as( SEXP x ){
            if( ::Rf_length(x) != 1 ) throw ::Rcpp::not_compatible( "expecting a single value" ) ;
            const int RTYPE = ::Rcpp::traits::r_sexptype_traits<T>::rtype ;
            SEXP y = PROTECT( r_cast<RTYPE>(x) );
            typedef typename ::Rcpp::traits::storage_type<RTYPE>::type STORAGE;
            T res = caster<STORAGE,T>( *r_vector_start<RTYPE>( y ) ) ;
            UNPROTECT(1) ;
            return res ; 
        }
        
        template <typename T> T as( SEXP x, ::Rcpp::traits::r_type_primitive_tag ) {
            return primitive_as<T>(x) ;
        }
        
        inline const char* check_single_string( SEXP x){
            if( TYPEOF(x) == CHARSXP ) return CHAR( x ) ;
            if( ! ::Rf_isString(x) )
                throw ::Rcpp::not_compatible( "expecting a string" ) ;
            if (Rf_length(x) != 1)
                throw ::Rcpp::not_compatible( "expecting a single value");
            return CHAR( STRING_ELT( ::Rcpp::r_cast<STRSXP>(x) ,0 ) ) ;
        }
        
        
        template <typename T> T as_string( SEXP x, Rcpp::traits::true_type){
            const char* y = check_single_string(x) ;
            return std::wstring( y, y+strlen(y)) ;
        }
        
        template <typename T> T as_string( SEXP x, Rcpp::traits::false_type){
            return check_single_string(x) ;
        }
        
        template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_string_tag ) {
            return as_string<T>( x, typename Rcpp::traits::is_wide_string<T>::type() );
        }
        
        template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_RcppString_tag ) {
            if( ! ::Rf_isString(x) ){
                throw ::Rcpp::not_compatible( "expecting a string" ) ;
            }
            if (Rf_length(x) != 1) {
                throw ::Rcpp::not_compatible( "expecting a single value");
            }
            return STRING_ELT( ::Rcpp::r_cast<STRSXP>(x) ,0 ) ;
        }
        
        template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_generic_tag ) {
            RCPP_DEBUG_1( "as(SEXP = <%p>, r_type_generic_tag )", x ) ;
            ::Rcpp::traits::Exporter<T> exporter(x);
            RCPP_DEBUG_1( "exporter type = %s", DEMANGLE(exporter) ) ;
            return exporter.get() ;
        }
        
        void* as_module_object_internal(SEXP) ;
        template <typename T> object<T> as_module_object(SEXP x){
            return (T*) as_module_object_internal(x) ;
        }
        
        template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_module_object_pointer_tag ) {
            return as_module_object<typename T::object_type>( x ) ;
        }
        
        template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_module_object_tag ){
            T* obj = as_module_object<T>(x) ;
            return *obj ;
        }
        
        template <typename T> T as(SEXP x, ::Rcpp::traits::r_type_enum_tag ){
            return T( primitive_as<int>(x) ) ;
        }
        
    }
        
        
    template <typename T> T as( SEXP m_sexp) {
        return internal::as<T>( m_sexp, typename traits::r_type_traits<T>::r_category() ) ;
    }
    
    template <typename T> 
    inline typename traits::remove_const_and_reference<T>::type bare_as( SEXP m_sexp ){
        return as< typename traits::remove_const_and_reference<T>::type >( m_sexp ) ;
    }
    
    template<> inline SEXP as(SEXP m_sexp) { return m_sexp ; }

} // Rcpp 

#endif