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