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