1# Copyright (C) 2013 - 2016 John Chambers, Dirk Eddelbuettel and Romain Francois 2# 3# This file is part of Rcpp. 4# 5# Rcpp is free software: you can redistribute it and/or modify it 6# under the terms of the GNU General Public License as published by 7# the Free Software Foundation, either version 2 of the License, or 8# (at your option) any later version. 9# 10# Rcpp is distributed in the hope that it will be useful, but 11# WITHOUT ANY WARRANTY; without even the implied warranty of 12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# GNU General Public License for more details. 14# 15# You should have received a copy of the GNU General Public License 16# along with Rcpp. If not, see <http://www.gnu.org/licenses/>. 17 18.stdHeader <- c( # #nocov start 19 "#include <Rcpp.h>", 20 "using namespace Rcpp ;" 21 ) 22 23.asString <- function(what) if(is.character(what)) what else deparse(what) 24 25.strings <- function(expr) { 26 if(is.call(expr) && ! identical(expr[[1]], quote(`::`))) 27 lapply(as.list(expr)[-1], .strings) 28 else 29 .asString(expr) 30} 31 32.specifyItems <- function(what) { 33 what <- as.list(what) 34 wn <- allNames(what) 35 simple <- !nzchar(wn) 36 ## todo: error checking here that unnamed elements are single strings 37 wn[simple] <- as.character(what[simple]) 38 names(what) <- wn 39 what[simple] <- list(character()) 40 what 41} 42 43.writeFieldFunction <- function(fldi, typei, CppClass, readOnly, ns, con){ 44 rootName <- paste0("field_", fldi) 45 writeLines(sprintf(" %s %s_get(%s *obj) { return obj->%s; }\n", 46 typei, rootName, CppClass, fldi), con) 47 value <- "_get" 48 if(!readOnly) { 49 writeLines(sprintf(" void %s_set(%s *obj, %s value) { obj->%s = value; }\n", 50 rootName, CppClass, typei, fldi), con) 51 value <- c(value, "_set") 52 } 53 paste0(ns, "::field_", fldi, value) 54} 55 56.writeMethodFunction <- function(mdi, sigi, CppClass, ns, con) { 57 mName <- paste0("method_", mdi) 58 if(length(sigi) < 1) 59 stop(gettextf("The type signature for method %s for class %s was of length 0: Must at least include the return type", 60 mdi, CppClass)) 61 rtnType <- sigi[[1]] 62 sigi <- sigi[-1] 63 if(length(sigi)) { 64 argNames <- paste0("a", seq_along(sigi)) 65 args <- paste(" ,", paste(sigi, argNames, collapse = ", ")) 66 } 67 else argNames <- args <- "" 68 writeLines(sprintf(" %s %s(%s *obj%s){ return obj->%s(%s); }\n", 69 rtnType, mName, CppClass, args, mdi, argNames), con) 70 paste0(ns, "::",mName) 71} 72 73exposeClass <- function(class, constructors, fields, methods, 74 file = paste0(CppClass, "Module.cpp"), 75 header = character(), 76 module = paste0("class_",class), CppClass = class, 77 readOnly = character(), rename = character(), 78 Rfile = TRUE) { 79 ## some argument checks 80 ## TODO: checks on constructors, fields, methods 81 if(length(readOnly)) { 82 readOnly <- as.character(readOnly) 83 if(!all(nzchar(readOnly))) 84 stop("argument readOnly should be a vector of non-empty strings") 85 } 86 newnames <- allNames(rename) 87 if(length(rename)) { 88 if(!all(sapply(rename, function(x) is.character(x) && length(x) == 1 && nzchar(x)))) 89 stop("argument rename should be a vector of single, non-empty strings") 90 if(!all(nzchar(newnames))) 91 stop("all the elements of argument rename should be non-empty strings") 92 } 93 if(is.character(file)) { 94 ## are we in a package directory? Writable, searchable src subdirectory: 95 if(file.access("src",3)==0 && (basename(file) == file)) 96 cfile <- file.path("src", file) 97 else 98 cfile <- file 99 con <- file(cfile, "w") 100 on.exit({message(sprintf("Wrote C++ file \"%s\"", cfile)); close(con)}) 101 } 102 else 103 con <- file 104 ## and for the R code: 105 if(identical(Rfile, FALSE)) {} 106 else { 107 if(identical(Rfile, TRUE)) 108 Rfile <- sprintf("%sClass.R",class) 109 if(is.character(Rfile)) { 110 if(file.access("R",3)==0 && (basename(file) == file)) # in a package directory 111 Rfile <- file.path("R", Rfile) 112 Rcon <- file(Rfile, "w") 113 msg <- sprintf("Wrote R file \"%s\"",Rfile) 114 on.exit({message(msg); close(Rcon)}, add = TRUE) 115 } 116 else 117 Rcon <- Rfile 118 Rfile <- TRUE 119 } 120 mfile <- tempfile() 121 mcon <- file(mfile, "w") 122 writeLines(.stdHeader, con) 123 if(length(header)) 124 writeLines(header, con) 125 writeLines(c("", sprintf("RCPP_MODULE(%s) {\n",module), ""), mcon) 126 writeLines(sprintf(" class_<%s>(\"%s\")\n", CppClass, class), mcon) 127 128 ## the constructors argument defines a list of vectors of types 129 for( cons in constructors) { 130 if(length(cons) > 1 || 131 (length(cons) == 1 && nzchar(cons) && !identical(cons, "void"))) 132 cons <- paste0("<", paste(cons, collapse = ","),">") 133 else 134 cons = "" 135 writeLines(paste0(" .constructor",cons,"()"),mcon) 136 } 137 writeLines("", mcon) 138 flds <- .specifyItems(fields) 139 nm <- fnm <- names(flds) 140 rdOnly <- nm %in% readOnly 141 macros <- ifelse(rdOnly, ".field_readonly", ".field") 142 test <- nm %in% rename 143 if(any(test)) 144 nm[test] <- newnames[match(nm[test], rename)] 145 ns <- NULL 146 for(i in seq_along(nm)) { 147 typei <- flds[[i]] 148 fldi <- fnm[i] 149 nmi <- nm[[i]] 150 macroi <- macros[[i]] 151 if(!length(typei) || identical(typei, "")) ## direct field 152 writeLines(sprintf(" %s(\"%s\", &%s::%s)", 153 macroi, nmi, CppClass, fldi), mcon) 154 else { # create a free function, e.g. for an inherited field 155 if(is.null(ns)) { # enclose in a namespace 156 ns <- paste("module",class,"NS", sep = "_") 157 writeLines(sprintf("\nnamespace %s {\n", ns), 158 con) 159 } 160 fldFuns <- .writeFieldFunction(fldi, typei, CppClass, rdOnly[[i]], ns, con) 161 if(rdOnly[[i]]) 162 ## NOTE: string 3rd arg. required by problem w. module parsing 10/3/13 163 writeLines(sprintf(" .property(\"%s\", &%s, \"read-only field\")", 164 nmi, fldFuns[[1]]), mcon) 165 else 166 writeLines(sprintf(" .property(\"%s\", &%s, &%s)", 167 nmi, fldFuns[[1]], fldFuns[[2]]), mcon) 168 } 169 } 170 writeLines("", mcon) 171 sigs <- .specifyItems(methods) 172 nm <- mds <- names(sigs) 173 test <- nm %in% rename 174 if(any(test)) 175 nm[test] <- newnames[match(nm[test], rename)] 176 for(i in seq_along(nm)) { 177 sigi <- sigs[[i]] 178 nmi <- nm[[i]] 179 mdi <- mds[[i]] 180 if(!length(sigi) || identical(sigi, "")) # direct method 181 writeLines(sprintf(" .method(\"%s\", &%s::%s)", 182 nmi, CppClass, mdi), mcon) 183 else { # create a free function, e.g. for an inherited method 184 if(is.null(ns)) { # enclose in a namespace 185 ns <- paste("module",class,"NS", sep = "_") 186 writeLines(sprintf("\nnamespace %s {\n", ns), 187 con) 188 } 189 mFun <- .writeMethodFunction(mdi, sigi, CppClass, ns, con) 190 writeLines(sprintf(" .method(\"%s\", &%s)", 191 nmi, mFun), mcon) 192 } 193 } 194 195 writeLines(" ;\n}", mcon) 196 close(mcon) 197 if(!is.null(ns)) 198 writeLines(sprintf("} // %s", ns), con) # close namespace 199 writeLines(readLines(mfile), con) 200 if(Rfile) { 201 if(missing(CppClass)) 202 CppString <- "" 203 else 204 CppString <- paste0(", \"",CppClass, "\"") 205 if(missing(module)) 206 ModString <- "" 207 else 208 ModString <- paste0(", module = \"", module, "\"") 209 writeLines(sprintf("%s <- setRcppClass(\"%s\"%s%s)", 210 class, class, CppString,ModString), Rcon) 211 } 212} # #nocov end 213 214 215 216