R/registration.R

In bnaras/SUtools: Stanford University Utilities for Fortran and Mortran

#' Generate registration from fortran subroutine
#'
#' This uses uses implicit fortran conventions
#' @param pkg_name the package name as character
#' @param fun_list the list of fortran function prototypes, see
#'     example
#' @param callEntries a character vector defining code that will be included verbatim that will define the C array `CallEntries[]`, default `NULL`
#' @return lines that can be written into an init file for the package
#' @export
#' @examples
#' ## Most common use
#' fns <- c("subroutine pclasso(no,ni,x,y,w,theta,ng,mg,aa,ne,nx,nlam,ulam,thr,maxit,verbose,ao,ia,kin,nlp,jerr)", "subroutine logpclasso(no,ni,x,y,w,theta,ng,mg,aa,ne,nx,nlam,ulam,thr,maxit,verbose,a0,ao,ia,kin,nlp,jerr)")
#' # Generate lines that can be written into pcLasso/src/pcLasso_init.c for example
#' gen_registration("pcLasso", fns)
#'
#' ## Example using callEntries
#' callEntries <- c(
#'   'extern SEXP store_rfun(SEXP rfun);',
#'   'static const R_CallMethodDef CallEntries[] = {',
#'      '{"store_rfun", (DL_FUNC) &store_rfun, 1}',
#'      '{NULL, NULL, 0}',
#'   '};')
#' gen_registration("pcLasso", fns, callEntries = callEntries)
#'
gen_registration <- function(pkg_name, fun_list, callEntries = NULL) {
    cat("Generating Init function for package", pkg_name, "\n")
    pkg_name_pattern_uc <- "R_PKG_NAME"
    pkg_name_pattern <- "r_pkg_name"

    pkg_name_uc <- toupper(pkg_name)

    prolog <- c(
        "// Automatically generated by SUtools, editing not advised.",
        '#ifndef R_R_PKG_NAME_H',
        '#define R_R_PKG_NAME_H',
        '#include <R.h>',
        '#include <Rinternals.h>',
        '#include <R_ext/Rdynload.h>',
        '#ifdef ENABLE_NLS',
        '#include <libintl.h>',
        '#define _(String) dgettext ("r_pkg_name", String)',
        '#else',
        '#define _(String) (String)',
        '#endif',
        '',
        callEntries,
        '',
        '#define FDEF(name)  {#name, (DL_FUNC) &F77_SUB(name), sizeof(name ## _t)/sizeof(name ## _t[0]), name ##_t}')

    prolog <- gsub(pkg_name_pattern_uc, pkg_name_uc, prolog)
    prolog <- gsub(pkg_name_pattern, pkg_name, prolog)

    gen_types <- function(name, args, ...) {
        ## Quite primitive, but will do the job mostly
        doubles <- grep("^[[:space:]]*double", args)
        ints <- grep("^[[:space:]]*int", args)
        chars <- grep("^[[:space:]]*char", args)
        delims <- c(rep(",", length(args) - 1), "")
        out1 <- c(
            sprintf("void F77_SUB(%s)(", name),
            paste0(args, delims),
            ");")
        argOut <- rep("REALSXP", length(args))
        argOut[ints] <- "INTSXP"
        argOut[chars] <- "STRSXP"
        out2 <- c(
            sprintf("static R_NativePrimitiveArgType %s_t[] = {", name),
            paste0(argOut, delims),
            "};")
        c(out1, " ", out2)
    }
    fun_list <- make_fun_list(fun_list)
    out3 <- sapply(fun_list, function(x) sprintf("FDEF(%s)", x$name))


    epilog <- c(
        'void R_init_r_pkg_name(DllInfo *dll){',
        ifelse(is.null(callEntries),
               '  R_registerRoutines(dll, NULL, NULL, fMethods, NULL);',
               '  R_registerRoutines(dll, NULL, callEntries, fMethods, NULL);'),
        '  R_useDynamicSymbols(dll, FALSE);',
        '}',
        '#endif')

    epilog <- gsub(pkg_name_pattern_uc, pkg_name_uc, epilog)
    epilog <- gsub(pkg_name_pattern, pkg_name, epilog)

    c(prolog,
      unlist(lapply(fun_list, function(x) do.call(gen_types, x))),
      "",
      "static R_FortranMethodDef fMethods[] = {",
      paste(out3, ","),
      "{NULL, NULL, 0}",
      "};",
      "",
      epilog)
}


#' Make C argument types
#'
#' This uses implicit fortran conventions, that is
#' integers for variables prefixed with i through n and reals for others
#' @param ... list of variable names, as is
#' @import stringr
#' @export
#' @examples
#' make_c_args(no,ni,x,y,w,theta,ng,mg,aa,ne,nx,nlam,ulam,thr,maxit,verbose,ao,ia,kin,nlp,jerr)
#'
#'
make_c_args <-    function(...){
    ## my own little helper function
    args <- stringr::str_trim(as.character(substitute(list(...)))[-1])
    int_type <- substring(args, 1, 1) %in% c("i","j","k","l","m","n")
    type <- ifelse(int_type, "int", "double")
    paste0(type, " *", args)
}

#' Make SEXP argument types
#'
#' @param ... list of variable names, as is
#' @import stringr
#' @export
#' @examples
#' make_sexp_args(no,ni,x,y,w,theta,ng,mg,aa,ne,nx,nlam,ulam,thr,maxit,verbose,ao,ia,kin,nlp,jerr)
#'
#'
make_sexp_args <-    function(...){
    ## my own little helper function
    args <- stringr::str_trim(as.character(substitute(list(...)))[-1])
  paste0("SEXP ", args)
}

#' Make call argument types
#'
#' This uses implicit fortran conventions, that is
#' integers for variables prefixed with i through n and reals for others
#' @param ... list of variable names, as is
#' @import stringr
#' @export
#' @examples
#' make_call_args(no,ni,x,y,w,theta,ng,mg,aa,ne,nx,nlam,ulam,thr,maxit,verbose,ao,ia,kin,nlp,jerr)
#'
#'
make_call_args <-    function(...){
    ## my own little helper function
    args <- stringr::str_trim(as.character(substitute(list(...)))[-1])
    int_type <- substring(args, 1, 1) %in% c("i","j","k","l","m","n")
  type <- ifelse(int_type, "INTEGER", "REAL")
  paste0(type, "(", args, ")")
}


#' Generate function name and C arg types from subroutine/entry definition
#'
#' Parse a fortran subroutine/entry definition and return subroutine/entry name and
#' C argument types as a list
#' @param fun_str a vector of subroutine definition strings with args
#' @importFrom stringr str_match
#' @return a list of function names along with C argument types, SEXP args, and .Call args
#' @export
#' @examples
#' make_fun_list(c("subroutine foo(no,ni,x,y,w,theta)", "entry foobar(ix, y)", "subroutine bar(x,n,p,m)"))
#'
#'
make_fun_list <- function(fun_strs) {
    lapply(fun_strs,
           function(fun_str) {
               fun <- stringr::str_match(fun_str, "(subroutine|entry)\\s+(\\w+)\\s*\\(")[, 3]
               args <-  strsplit(stringr::str_match(fun_str, "\\((.*)\\)"), ",")[[2]]
               list(name = fun, args = do.call(make_c_args, as.list(args)),
                    sexp_args = do.call(make_sexp_args, as.list(args)),
                    call_args = do.call(make_call_args, as.list(args)),
                    arg_names = args)
           })
}

#' Generate C stub and R stub for making a .Call to a Fortran function
#'
#' Parse a fortran subroutine/entry definition and return a C routine that can be used with .Call and R call snippet
#' @param fun_str a vector of subroutine definition strings with args
#' @importFrom stringr str_match
#' @return a named list of C code and R code for each function
#' @export
#' @examples
#' make_dotcall_to_fortran(c("subroutine foo(no,ni,x,y,w,theta)", "entry foobar(ix, y)", "subroutine bar(x,n,p,m)"))
#'
make_dotcall_to_fortran <- function(fun_strs) {
  funs <- sapply(fun_strs, function(fun_str) stringr::str_match(fun_str, "(subroutine|entry)\\s+(\\w+)\\s*\\(")[, 3])
  result  <- lapply(fun_strs,
                    function(fun_str) {
                      fun <- stringr::str_match(fun_str, "(subroutine|entry)\\s+(\\w+)\\s*\\(")[, 3]
                      args <-  strsplit(stringr::str_match(fun_str, "\\((.*)\\)"), ",")[[2]]
                      sexp_args  <- do.call(make_sexp_args, as.list(args))
                      call_args  <- do.call(make_call_args, as.list(args))

                      list(c = c(sprintf("SEXP c_%s(%s) {", fun, paste(sexp_args, collapse = ",")),
                                 sprintf("\tF77_NAME(%s)(%s);", fun, paste(call_args, collapse = ",")),
                                 sprintf("\treturn(R_NilValue);"),
                                 "}"
                                 ),
                           r = c(sprintf("result <- list(%s)", paste0(args, "=", args, collapse=",")),
                                 sprintf(".Call('c_%s', %s)", fun, paste0("result$", args, collapse = ","))
                                 )
                           )
                    })
  names(result)  <- funs
  result
}