template.R

In t-kalinowski/rfort: What the Package Does (One Line, Title Case)

library(yasp)
library(glue)




new_arg <- function(name, type, rank = length(dims),
                    dims = NULL,
                    modifiable = FALSE,
                    optional = FALSE) {
  type <- switch(type,
    "dbl" = , "double" = "double",
    "int" = , "integer" = "integer",
    "cmp" = , "complex" = "complex",
    "lgl" = , "logical" = "logical",
    stop("Unsupported type"))
  rank <- as.integer(rank)
  out <- as.list(environment())
  class(out) <- "rfort_arg"
  out
}


expand_args <- function(x) {
  stopifnot(is.list(x), map_lgl(x, ~ inherits(.x, "rfort_arg")))

  x <- lapply(x, function(arg) {
    if (arg$rank == 0) return(list(arg))
    about <- new_arg(glue("{arg$name}__size"), "int", dims = arg$rank)
    class(about) <- unique(c("rfort_size_arg", class(x)))
    list(about, arg)
  })

  x <- lapply(x, function(arg) {
    class(x) <- unique(c("expanded_rfort_arg", class(x)))
    x
  })

  x <- unlist(x, recursive = FALSE)
  class(x) <- "expanded_arg_list"
  x
}

get_arg_f_decl <- function(x) {
  stopifnot(inherits(x), "rfort_arg")
  type <- switch(
    x$type,
    "double" = "real(c_double)",
    "integer" = "integer(c_int)",
    "complex" = "complex(c_double_complex)",
    "logical" = "logical(c_bool)"
  )

  intent <- if (modifiable) "in out" else "in"
  intent <- glue("intent({intent})")

  if (rank == 0) {
    manifest <- glue("{type}, {intent} :: {name}")
    return(manifest)
  }

  manifest <- c(
      glue("integer(c_int), intent(in) :: {name}__size"),
      glue("{type}, {intent} :: {name}({name}__length)")
    )
    names(manifest) <- c(glue("{name}__length"), name)
    return(manifest)
  }

build_fsub_manifest <- function(x) {
  stopifnot(inheritx(x, "expanded_arg_list"))
  x <- lapply(x, get_arg_f_decl)
}



arg_manifest <- function(name, type, rank = 0,
                         modifiable = FALSE,
                         optional = FALSE) {
  # TODO add optional, contiguious
  type <- switch(
    type,
    "dbl" = , "double" = "real(c_double)",
    "int" = , "integer" = "integer(c_int)",
    "cmp" = , "complex" = "complex(c_double_complex)",
    "lgl" = , "logical" = "logical(c_bool)"
  )

  intent <- if (modifiable) "in out" else "in"
  intent <- glue("intent({intent})")

  if (rank == 0) {
    manifest <- glue("{type}, {intent} :: {name}")
    names(manifest) <- name
    return(manifest)
  }

  if (rank == 1) {
    manifest <- c(
      glue("integer(c_int), intent(in) :: {name}__length"),
      glue("{type}, {intent} :: {name}({name}__length)")
    )
    names(manifest) <- c(glue("{name}__length"), name)
    return(manifest)
  }

  dims_decl <- glue("{name}__dims({1:rank})")
  dims_decl <- paste0(dims_decl, collapse = ", ")

  manifest <- c(
    glue("integer(c_int), intent(in) :: {name}__dims({rank})"),
    glue("{type}, {intent} :: {name}({dims_decl})")
  )
  names(manifest) <- c(glue("{name}__dims"), name)
  manifest
}



build_sub <- function(name, manifest, body) {
  args <- pcc(names(manifest))
  manifest <- pcnl("  ", manifest)
  body <- pcnl("  ", body)
  glue(
    "subroutine {name}({args})
    {manifest}

    {body}
    end subroutine {name}"
  )
}
build_c_decl <- function(name, args) {



}

make_cshift_subs <- function() {
  body <- "array = cshift(array, shift)"
  subs <- list()
  c_decl <- list()
  for (rank in 0:7)
  for (type in c("int", "dbl", "cmp", "lgl"))
  for (ranked_shift in c(TRUE, FALSE)) {
    shift_typ <- if (ranked_shift)
      "ranked"
    else
      "scalar"
    name <- glue("cshift_{type}_rank_{rank}_shift_{shift_typ}")
    arr <- arg_manifest("array", type, rank, TRUE)
    shift <-
      arg_manifest("shift", "int", if (ranked_shift)
        rank - 1
        else
          0)

    subs[[name]] <-
      build_sub(name, c(arr, shift), body)

    # c_decl[[name]] <- build_c_decl(name, c(arr, shift), body)
  }
  subs
}

cshift_subs <- make_cshift_subs()


# name <- "cshiftit"
#
# manifest <-
#   c(arg_manifest("array", "dbl", 2, TRUE),
#     arg_manifest("shift", "int", 0))
# body <- "array = cshift(array, shift)"
#
# build_sub(name, manifest, body)

#
#
# for (rank in 1:4) {
#   arr
# }
# glue()
#
#
#
# type <- "dbl"
# name = "foo"
# rank = 3L
# modifiable <- TRUE

#
# arg_manifest("dbl", "array", 2)
#
#
# manifest <-
#   c(arg_manifest("array", "dbl", 2, TRUE),
#     arg_manifest("shift", "int", 0))
#
# args