check_type_call <- function(cl) {
  if (length(cl) > 2)
    stop("only one variable can be declared per type() call")
  args <- as.list(cl)[-1]
  if (length(names(args)) != 1)
    stop("name must be provided as: type(<name> = <mode>(<<dims>>)")
  if (!is.call(args[[1]]) && as.character(args[[1]]) %in% .atomic_type_names)
    stop("only atomic modes are supported")
}

type_call_to_var <- function(cl) {
  check_type_call(cl)
  Variable(
    name = names(cl)[-1],
    mode = as.character(cl[[2L]][[1L]]),
    dims = unname(as.list(cl[[2]])[-1])
  )
}

var_to_type_call <- function(var) {
  arg <- as.call(c(as.symbol(var@mode), var@dims))
  arg <- setNames(list(arg), var@name)
  as.call(c(quote(type), arg))
}

get_flattened_args <- function(cl) {
  # flatten exprs from `{` in usage like declare({ ... })`
  args <- as.list(cl)[-1]
  args <- lapply(args, function(e) {
    if (is_missing(e))
      NULL
    else if (is_call(e, quote(`{`)))
      get_flattened_args(e)
    else
      list(e)
  })
  unlist(args, recursive = FALSE)
}

self_evaluate <- function(...) sys.call()

substitute_declared_sizes <- function(e) {
  stopifnot(is_call(e, quote(`{`)))

  aliases <- new.env(parent = emptyenv())
  eval_env <- new.env(parent = emptyenv())
  for(name in all.names(e, functions = TRUE, unique = TRUE))
    assign(name, self_evaluate, eval_env)
  eval_env <- new.env(parent = eval_env)
  for(name in all.names(e, functions = FALSE, unique = TRUE))
    assign(name, as.symbol(name), eval_env)

  eval_env$`{` <- function(...) {
    as.call(c(list(quote(`{`)), list(...)))
  }

  eval_env$declare <- function(...) {
    args <- get_flattened_args(sys.call())
    args <- lapply(args, function(e) {
      if (is_type_call(e)) {
        var <- type_call_to_var(e)
        var@dims <- imap(var@dims,

)
        e <- var_to_type_call(var)
      }
      e
    })

    as.call(c(quote(declare), args))
  }

  e <- eval(e, eval_env)

  # Now the 'aliases' env is populated; go through and substitute
  # size aliases with the actual size name.
  eval_env$declare <- function(...) {
    as.call(lapply(sys.call(), function(e) {
      if (is_type_call(e))
        e <- substitute_(e, aliases)
      e
    }))
  }

  eval(e, eval_env)

}

r2size <- function(r, scope) {
  typeof(r) |> switch(
    integer = r,
    double = {
      if (is_wholenumber(r))
        as.integer(r)
      else
        stop("size must be an integer, found: ", r)
    },
    symbol = {
      if (is_size_name(r))
        return(r)
      var <- get(r, scope)
      if (var@mode != "integer" || !passes_as_scalar(var))
        warning("size is not an integer:", as.character(r))
      if (var@is_arg && !var@modified)
        return(r)
      # TODO: add specific unit tests here
      if (identical(var@r, r))
        return(r)
      # make a best effort to use the r expression last assigned to the
      # symbol, or fail gracefully and return NA.
      # closure-locals with unspecified shape are declared allocatable
      # input and/or output args with unspecified shape signal an error.
      r2size(var@r, scope)
    },
    language = {
      as.character(r[[1]]) |> switch(
        `+` = , `-` = , `/` = , `*` = , `^` = , `%/%` = , `%%` = {
          args <- as.list(r)[-1]
          args <- lapply(args, r2size, scope)
          if (anyNA(rapply(args, as.list)))
            return(NA_integer_)
          cl <- as.call(c(r[[1]], args))
          if (all(map_lgl(args, is.atomic)))
            cl <- eval(cl, baseenv())
          cl
        },
        length = {
          var <- get(r[[2L]], scope)
          if (var@rank == 1)
            return(var@dims[[1L]])
          len <- reduce(var@dims, \(d1, d2) call("*", d1, d2))
          r2size(len, scope)
        },
        `[` = {
          # [ only works when paired with dim()
          if (!is_call(r[[2L]], quote(dim)))
            return(NA_integer_)
          var <- get(r[[2L]][[2L]], scope)
          axis <- r[[3]]
          if (!is_wholenumber(axis))
            return(NA_integer_)
          if (axis > var@rank)
            stop("insufficient rank of variable in ", deparse1(r))
          var@dims[[axis]]
        },
        # dim = {
        #
        # },
        nrow = {
          var <- get(r[[2L]], scope)
          var@dims[[1]]
        },
        ncol = {
          var <- get(r[[2L]], scope)
          var@dims[[2]]
        },
        NA_integer_)
    },
    NA_integer_
  )
}

r2dims <- function(r, scope) {
  if (is.call(r)) {
    as.character(r[[1]]) |> switch(
      dim = {
        var <- get(r[[2L]], scope)
        return(var@dims)
      },
      c = {
        args <- lapply(r[-1], r2dims, scope)
        dims <- unlist(args, recursive = FALSE)
        return(as.list(dims))
      },
      r <- list(r))
  }
  lapply(r, r2size, scope)
}

get_size_name <- function(var, axis = NULL, name = var@name, rank = var@rank) {
  stopifnot(is.null(axis) || is_wholenumber(axis) && axis > 0)
  if (is.null(axis) || rank == 1 && axis == 1)
    sprintf("%s__len_", name)
  else {
    if (axis > rank) stop("axis must not be > rank")
    sprintf("%s__dim_%i_", name, axis)
  }
}

# TODO: allow syntax like:
#   declare(type(a, b, c = integer(1)))
# or:
#   declare(type(a = , b = , c = integer(1)))

function(size, axis) {
          size_name <- as.symbol(get_size_name(var, axis))
          if (is.symbol(size) && !exists(size, aliases)) {
            assign(as.character(size), size_name, aliases)
            size <- size_name
          } else if (is_scalar_na(size)) {
            size <- size_name
          } else if (is_wholenumber(size)) {
            size <- as.integer(size)
          }
          size
        }

# Take parsed R code (anything returnable by base::str2lang()) and returns
# a Fortran object, which is a string of Fortran code and some attributes
# describing the value.
lang2fortran <- r2f <- function(e, scope = NULL, ..., calls = character(), hoist = NULL) {
  ## 'hoist()' is a function that individual handlers can call to pre-emit some
  ## Fortran code. E.g., to setup a temporary variable if the generated Fortran
  ## code doesn't neatly translate into a single expression.
  hoisted <- character()
  if (is.null(hoist)) {
    delayedAssign("hoist_connection", textConnection("hoisted", "w", TRUE))
    hoist <- function(...) {
      writeLines(as.character(unlist(c(character(), ...))),
                 hoist_connection)
    }
  # if performance with textConnection() becomes an issue, maybe switch to an
  # anonymous file(), though, each hoisting context is typically shortlived and
  # usually 0 lines are hoisted per context, and if they are hoisted, a small number.
  }

  fortran <- switch(typeof(e),
      language = {
        # a call
        handler <- get_r2f_handler(callable <- e[[1L]])

        match.fun <- attr(handler, "match.fun", TRUE)
        if (is.null(match.fun)) {
          match.fun <- get0(callable, parent.env(globalenv()),
                            mode = "function")
          # this is a best effort to, eg. resolve `seq.default` from `seq`.
          # This should likely be moved into attaching the `match.fun` attr
          # to handlers, for more involved resolution (e.g., with getS3Method())
          if ("UseMethod" %in% all.names(body(match.fun)))
            match.fun <- get0(paste0(callable, ".default"),
                              parent.env(globalenv()),
                              mode = "function",
                              ifnotfound = match.fun)
        }
        if (typeof(match.fun) == "closure") {
          e <- match.call(match.fun, e)
        }

        if (isTRUE(getOption("quickr.r2f.debug"))) {

          try(handler(as.list(e)[-1L], scope, ...,
                      calls = c(calls, as.character(callable)),
                      hoist = hoist)) -> res
          if (inherits(res, "try-error")) {
            debugonce(handler)
            handler(as.list(e)[-1L], scope, ...,
                    calls = c(calls, as.character(callable)),
                    hoist = hoist)
          }

          res

        } else {

          handler(as.list(e)[-1L], scope, ...,
                  calls = c(calls, as.character(callable)),
                  hoist = hoist)

        }

      },

      integer = ,
      double = ,
      complex = ,
      logical =  atomic2Fortran(e),

      symbol = {
        s <- as.character(e)
        # logicals that come in from R are passed as integer types,
        # so for all fortran ops we cast to logical with /=0
        if (
          !is.null(scope[[e]] -> val) &&
            val@mode == "logical" &&
            val@is_external
        ) {
          s <- paste0("(", s, "/=0)")
        }
        Fortran(s, value = scope[[e]])
      },

      ## handling 'object' and 'closure' here are both bad ideas,
      ## TODO: delete both
      # "object" = {
      #   if (inherits(e, Variable))
      #     e <- Fortran(character(), e)
      #   stopifnot(inherits(e, Fortran))
      #   e
      # },

      closure = {
        if (is.null(name <- attr(e, "name", TRUE))) {
          name <- if (is.symbol(name <- substitute(e)))
            as.character(name)
          else
            "anonymous_function"
        }

        stopifnot(is.null(scope))
        new_fortran_subroutine(name, e)
      },

      ## all the other typeof() possible values
      # "character",
      # "raw" ,
      # "list",
      # "NULL",
      # "function",
      # "special",
      # "builtin",
      # "environment",
      # "S4",
      # "pairlist",
      # "promise",
      # "char",
      # "...",
      # "any",
      # "expression",
      # "externalptr",
      # "bytecode",
      # "weakref"
      # default
      stop("Unsupported object type encountered: ", typeof(e))
    )

  if (length(hoisted)) {
    combined <- str_flatten_lines(c(hoisted, fortran))
    attributes(combined) <- attributes(fortran)
    fortran <- combined
  }

  attr(fortran, "r") <- e
  fortran
}

atomic2Fortran <- function(x) {
  stopifnot(is_scalar_atomic(x))
  s <- switch(typeof(x),
              double =,
              integer = num2fortran(x),
              logical = if (x) ".true." else ".false.",
              complex = sprintf("(%s, %s)", num2fortran(Re(x)), num2fortran(Im(x))))
  Fortran(s, Variable(typeof(x)))
}

num2fortran <- function(x) {
  stopifnot(typeof(x) %in% c("integer", "double"))
  digits <- 7L
  nsmall <- switch(typeof(x), integer = 0L, double = 1L)
  repeat {
    s <- format.default(x, digits = digits, nsmall = nsmall, scientific = 1L)
    if (x == eval(str2lang(s))) # eval() needed for negative and complex numbers
      break
    add(digits) <- 1L
    if (digits > 22L)
      stop("number formatting error: ", x, " formatted as : ", s)
  }
  paste0(s, switch(typeof(x), double = "_c_double", integer = "_c_int"))
}

r2f_handlers := new.env(parent = emptyenv())

get_r2f_handler <- function(name) {
  stopifnot("All functions called must be named as symbols" = is.symbol(name))
  get0(name, r2f_handlers) %||% stop("Unsupported function: ", name, call. = FALSE)
}

r2f_default_handler <- function(args, scope = NULL, ..., calls) {
  # stopifnot(is.call(e), is.symbol(e[[1L]]))

  x <- lapply(args, r2f, scope = scope, calls = calls, ...)
  s <- sprintf("%s(%s)", last(calls), str_flatten_commas(x[-1]))
  Fortran(s)
}

## ??? export as S7::convert() methods?
register_r2f_handler <- function(name, fun) {
  stopifnot(
    is_string(name),
    identical(formals(fun), alist(x = , scope = NULL))
  )

  r2f_handlers[[name]] <- fun
}

.r2f_handler_not_implemented_yet <- function(e, scope, ...) {
  stop(gettextf("'%s' is not implemented yet", as.character(e[[1L]])),
       call. = FALSE)
}

r2f_handlers[["declare"]] <- function(args, scope, ...) {

  for (a in args) {
    if (is_missing(a)) {
      next
    }
    if (is_type_call(a)) {
      var <- type_call_to_var(a)
      var@is_arg <- var@name %in% names(formals(scope@closure))
      scope[[var@name]] <- var
    } else if (is_call(a, quote(`{`))) {
      Recall(as.list(a)[-1], scope)
    }
  }

  Fortran("")
}

r2f_handlers[["Fortran"]] <- function(args, scope = NULL, ...) {
  if (!is_string(args[[1]]))
    stop("Fortran() must be called with a string")
  Fortran(args[[1]])
  # enable passing through literal fortran code
  # used like:
  #   Fortran("nearest(x, 1)", double(length(x)))
  #   Fortran("nearest(x, 1)", x)
  #   Fortran("x = nearest(x, 1)")
}

r2f_handlers[["("]] <- function(args, scope, ...) {
  r2f(args[[1L]], scope, ...)
}

r2f_handlers[["{"]] <- function(args, scope, ..., hoist = NULL) {
  # every top level R-expr / fortran statement gets its own hoist target.
  x <- lapply(args, r2f, scope, ...)
  code <- str_flatten_lines(x)

  # browser()
  value <- (if (length(args)) last(x)@value) %||% Variable()
  Fortran(code, value)
}

# ---- reduction intrinsics ----

create_mask_hoist <- function() {
  .hoisted_mask <- NULL

  try_set <- function(mask) {
    stopifnot(inherits(mask, Fortran), mask@value@mode == "logical")
    # each hoist can only accept one mask.
    if (is.null(.hoisted_mask)) {
      .hoisted_mask <<- mask
      return(TRUE)
    }
    # if the mask is identical, we accept it.
    if (identical(.hoisted_mask, mask)) {
      return(TRUE)
    }
    # can't hoist this mask.
    FALSE
  }

  get_hoisted <- function() .hoisted_mask

  environment()
}

r2f_handlers[["max"]] <-
r2f_handlers[["min"]] <-
r2f_handlers[["sum"]] <-
r2f_handlers[["prod"]] <- function(args, scope, ...) {
  intrinsic <- switch(last(list(...)$calls),
                      max = "maxval",
                      min = "minval",
                      sum = "sum",
                      prod = "product")

  reduce_arg <- function(arg) {
    mask_hoist <- create_mask_hoist()
    x <- r2f(arg, scope, ..., hoist_mask = mask_hoist$try_set)
    if(x@value@rank == 0)
      return(x)
    hoisted_mask <- mask_hoist$get_hoisted()
    s <- glue(
      if (is.null(hoisted_mask))
        "{intrinsic}({x})"
      else
        "{intrinsic}({x}, mask = {hoisted_mask})"
    )
    Fortran(s, Variable(x@value@mode))
  }

  if (length(args) == 1) {
    reduce_arg(args[[1]])
  } else {
    args <- lapply(args, reduce_arg)
    mode <- reduce_promoted_mode(args)
    s <- switch(last(list(...)$calls),
      max = glue("max({str_flatten_commas(args)})"),
      min = glue("min({str_flatten_commas(args)})"),
      sum = glue("({str_flatten(args, ' + ')})"),
      prod = glue("({str_flatten(args, ' * ')})")
    )
    Fortran(s, Variable(mode))
  }
}

r2f_handlers[["which.max"]] <-
r2f_handlers[["which.min"]] <-
function(args, scope = NULL, ...) {
  stopifnot(length(args) == 1)
  x <- r2f(args[[1L]], scope, ...)
  stopifnot("Values passed to which.max()/which.min() must be 1d arrays" = x@value@rank == 1)
  valout <- Variable(mode = "integer") # integer scalar

  if (x@value@mode == "logical") {
    val <- switch(last(list(...)$calls),
                  which.max = ".true.",
                  which.min = ".false.")
    f <- glue("findloc({x}, {val}, 1)")
  } else {
    intrinsic <- switch(last(list(...)$calls),
                        which.max = "maxloc",
                        which.min = "minloc")
    f <- glue("{intrinsic}({x}, 1)")
  }

  Fortran(f, valout)
}

r2f_handlers[["["]] <- function(args, scope, ..., hoist_mask = function(mask) FALSE) {

  # only a subset of R's x[...] features can be translated here. `...` can only be:
  # - a single logical mask, of the same rank as `x`. returns a rank 1 vector.
  # - a number of arguments matching the rank of `x`, with each being
  #   an integer of rank 0 or 1. In this case, a rank 1 logical becomes
  #   converted to an integer with

  var <- args[[1]]
  var <- r2f(var, scope, ...)

  idxs <- whole_doubles_to_ints(args[-1])
  idxs <- imap(idxs, function(idx, i) {
    if (is_missing(idx))
      Fortran(":", Variable("integer", var@value@dims[[i]]))
    else
      r2f(idx, scope, ...)
  })

  if (length(idxs) == 1 &&
      idxs[[1]]@value@mode == "logical" &&
      idxs[[1]]@value@rank == var@value@rank) {
    mask <- idxs[[1]]
    if (hoist_mask(mask))
      return(var)
    return(Fortran(glue("pack({var}, {mask})"), Variable(var@value@mode, dims = NA)))
  }

  if (length(idxs) != var@value@rank)
    stop("number of args to x[...] must match the rank of x, received:",
         deparse1(as.call(c(quote(`[`,args )))))

  drop <- args$drop %||% TRUE

  idxs <- lapply(idxs, function(subscript) {
    # if (!idx@value@rank %in% 0:1)
    #   stop("all args to x[...] must have rank 0 or 1",
    #        deparse1(as.call(c(quote(`[`,args )))))
    switch(
      paste0(subscript@value@mode, subscript@value@rank),
      logical0 = {
        Fortran(":", Variable("integer", NA))
      },
      logical1 = {
        # we convert to a temp integer vector, doing the equivalent of R's which()
        i <- scope@get_unique_var("integer")
        f <- glue("pack([({i}, {i}=1, size({subscript}))], {subscript})")
        return(Fortran(f, Variable("int", NA)))
      },
      integer0 = {
        if (drop)
          subscript
        else
          Fortran(glue("{subscript}:{subscript}"), Variable("int", 1))
      },
      integer1 = {
        subscript
      },
      # double0 = { },
      # double1 = { },
      stop(
        "all args to x[...] must be logical or integer of rank 0 or 1",
        deparse1(as.call(c(quote(`[`, args ))))
        )
    )
  })

  dims <- drop_nulls(lapply(idxs, \(idx) idx@value@dims[[1]]))
  outval <- Variable(var@value@mode, dims)
  Fortran(glue("{var}({str_flatten_commas(idxs)})"), outval)

}

r2f_handlers[[":"]] <- function(args, scope, ...) {
  # depending on context, this translation can vary.

  # x[a:b]    becomes   x(a:b)
  # for(i in a:b){}  becomes  do i = a,b ...
  # c(a:b)  becomes  ({tmp}, {tmp}=a,b)
  args <- whole_doubles_to_ints(args)
  .[start, end] <- lapply(args, r2f, scope, ...)
  step <- glue("sign(1, {end}-{start})")
  val <- Variable("integer", NA)
  fr <- switch(
    list(...)$calls |> drop_last() |> last(),
    "[" = glue("{start}:{end}:{step}"),
    "for" = glue("{start}, {end}, {step}"),
    {
      i <- scope@get_unique_var("integer")
      glue("[ ({i}, {i} = {start}, {end}, {step}) ]")
    }
    # default
  )
  Fortran(fr, val)
}

r2f_handlers[["seq"]] <- function(args, scope, ...) {
  args <- whole_doubles_to_ints(args) # only casts if trunc(dbl) == dbl
  if (!is.null(args$length.out) || !is.null(args$along.with)) {
    stop("seq(length.out=, along.with=) not implemented yet")
  }

  .[from, to, by] <- lapply(args, r2f, scope, ...)[c("from", "to", "by")]
  by <- by %||% Fortran(glue("sign(1, {to}-{from})"), Variable("integer"))

  # Fortran only supports integer sequences in do and implicit do contexts.
  # to make a double sequence, needs to be in via an implied map() call, like
  # seq(1, 10, .1) ->    [(x * 0.1, x = 10, 50)]
  #
  # e.g., i <- scope@get_unique_var("integer")
  # glue("[({i} * by, {i} = int(from/by), int(to/by))]")
  if (from@value@mode != "integer" ||
     to@value@mode != "integer" ||
     by@value@mode != "integer")
    stop("non-integer seq()'s not implemented yet.")

  # depending on context, this translation can vary.
  #
  # x[a:b]    becomes   x(a:b)
  # for(i in a:b){}  becomes  do i = a,b ...
  # c(a:b)  becomes  ({tmp}, {tmp}=a,b)
  val <- Variable("integer", NA)
  fr <- switch(
    list(...)$calls |> drop_last() |> last(),
    "[" = glue("{from}:{to}:{by}"),
    "for" = glue("{from}, {to}, {by}"),
    {
      i <- scope@get_unique_var("integer")
      glue("[ ({i}, {i} = {from}, {to}, {by}) ]")
    }
    # default
  )
  Fortran(fr, val)
}

r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
  .[mask, tsource, fsource] <- lapply(args, r2f, scope, ...)
  # (tsource, fsource, mask)
  mode <- tsource@value@mode
  dims <- conform(mask@value, tsource@value, fsource@value)@dims
  Fortran(glue("merge({tsource}, {fsource}, {mask})"),
          Variable(mode, dims))
}

r2f_handlers[["abs"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  Fortran(glue("abs({arg})"), arg@value)
}

# ---- pure elemental unary math intrinsics ----

## real and complex intrinsics
r2f_handlers[["sin"]] <-
r2f_handlers[["cos"]] <-
r2f_handlers[["tan"]] <-
r2f_handlers[["asin"]] <-
r2f_handlers[["acos"]] <-
r2f_handlers[["atan"]] <-
r2f_handlers[["sqrt"]] <-
r2f_handlers[["exp"]] <-
r2f_handlers[["log"]] <-
r2f_handlers[["floor"]] <-
r2f_handlers[["ceiling"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  intrinsic <- last(list(...)$calls)
  Fortran(glue("{intrinsic}({arg})"), arg@value)
}

r2f_handlers[["log10"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  f <- if(arg@value@mode == "complex") {
    glue("(log({arg}) / log(10.0_c_double))")
  } else {
    glue("log10({arg})")
  }
  Fortran(f, arg@value)
}

## accepts real, integer, or complex
r2f_handlers[["abs"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  if(arg@value@mode == "complex")
    arg@value@mode <- "double"
  Fortran(glue("abs({arg})"), arg@value)
}

# ---- complex elemental unary intrinsics ----

r2f_handlers[["Re"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("real({arg})"), val)
}

r2f_handlers[["Im"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("aimag({arg})"), val)
}

# Modulus (magnitude)
r2f_handlers[["Mod"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("abs({arg})"), val)
}

# Argument (phase angle, radians)
r2f_handlers[["Arg"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("atan2(aimag({arg}), real({arg}))"), val)
}

# conjg() returns a complex value; R uses Conj()
r2f_handlers[["Conj"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "complex"
  Fortran(glue("conjg({arg})"), val)
}

# ---- elemental binary infix operators ----

r2f_handlers[["+"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} + {right})"), conform(left@value, right@value))
}

r2f_handlers[["-"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} - {right})"), conform(left@value, right@value))
}

r2f_handlers[["*"]] <- function(args, scope = NULL, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} * {right})"), conform(left@value, right@value))
}

r2f_handlers[["/"]] <- function(args, scope = NULL, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} / {right})"), conform(left@value, right@value))
}

r2f_handlers[["^"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} ** {right})"), conform(left@value, right@value))
}

r2f_handlers[[">="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} >= {right})"), var)
}
r2f_handlers[[">"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} > {right})"), var)
}
r2f_handlers[["<"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} < {right})"), var)
}
r2f_handlers[["<="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} <= {right})"), var)
}
r2f_handlers[["=="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} == {right})"), var)
}
r2f_handlers[["!="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} /= {right})"), var)
}

# ---- remainder (%%) and integer division (%/%) ----
#
# R semantics:
#   x %%  y  ==  r   where  r has the sign of y  (divisor)
#   x %/% y  ==  q   where  q = floor(x / y)
# and  x == r + y * q  (within rounding error)
#
# Fortran intrinsics:
#   - MODULO(a,p)   : remainder with sign(p)
#   - FLOOR(x)      : greatest integer ≤ x      (real)
#   - AINT(x)       : truncation toward 0       (real)

r2f_handlers[["%%"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  out_val <- conform(left@value, right@value)
  # MODULO gives result with sign(right) – matches R %% behaviour
  Fortran(glue("modulo({left}, {right})"), out_val)
}

r2f_handlers[["%/%"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  out_val <- conform(left@value, right@value)

  expr <- switch(
    out_val@mode,
    integer = glue("int(floor(real({left}) / real({right})))"),
    double  = glue("floor({left} / {right})"),
    stop("%/% only implemented for numeric types")
  )

  Fortran(expr, out_val)
}

# TODO: the scalar || probably need some more type checking.
# TODO: gfortran supports implicit casting that of logical to integer when
# assigning a logical to a variable declared integer, converting `.true.` to `1`,
# but this is not a standard language feature, and Intel's `ifort` uses `-1` for `.true`.
# We should explicitly use
#   `merge(1_c_int, 0_c_int, <lgl>)` to cast logical to int.
r2f_handlers[["&"]] <-
r2f_handlers[["&&"]] <-
r2f_handlers[["|"]] <-
r2f_handlers[["||"]] <-
function(args, scope, ...) {
  args <- lapply(args, r2f, scope, ...)
  args <- lapply(args, function(a) {
    if (a@value@mode != "logical") {
      stop("must be logical")
    }
    a
  })
  .[left, right] <- args

  operator <- switch(last(list(...)$calls),
                     `&` = , `&&` = ".and.",
                     `|` = , `||` = ".or.")

  s <- glue("{left} {operator} {right}")
  val <- conform(left@value, right@value)
  val@mode <- "logical"
  Fortran(s, val)
}

# --- constructors  ----

r2f_handlers[["c"]] <- function(args, scope = NULL, ...) {
  ff <- lapply(args, r2f, scope, ...)
  s <- glue("[ {str_flatten_commas(ff)} ]")
  lens <- lapply(ff[order(map_int(ff, \(f) f@value@rank))], function(e) {
    rank <- e@value@rank
    if (rank == 0)
      1L
    else if (rank == 1)
      e@value@dims[[1]]
    else
      stop("all args passed to c() must be scalars or 1-d arrays")
  })
  mode <- reduce_promoted_mode(ff)
  len <- Reduce(\(l1, l2) {
    if (is_scalar_na(l1) || is_scalar_na(l2)) {
      NA
    } else if (is_wholenumber(l1) && is_wholenumber(l2)) {
      l1 + l2
    } else {
      call("+", l1, l2)
    }
  }, lens)
  Fortran(s, Variable(mode, list(len)))
}

r2f_handlers[["cbind"]] <- function(e, scope) {
  .NotYetImplemented()
  ee <- lapply(e[-1], r2f, scope)
  ncols <- lapply(ee, function(f) {
    if (f@value@rank %in% c(0, 1))
      1
    else if (f@value@rank == 2)
      f@value@dims[[2]]
  })
  ncols <- Reduce(\(a, b) call("+", a, b), ncols)
  ncols <- eval(ncols, scope@sizes)
}

r2f_handlers[["<-"]] <- function(args, scope, ...) {
  target <- args[[1]]
  if (is.call(target)) {
    # given a call like `foo(x) <- y`, dispatch to `foo<-`
    target_callable <- target[[1]]
    stopifnot(is.symbol(target_callable))
    name <- as.symbol(paste0(as.character(target_callable), "<-"))
    handler <- get_r2f_handler(name)
    return(handler(args, scope, ...)) # new hoist target
  }

  # It sure seems like it's be nice if the Fortran() constructor
  # took mode and dims as args directly,
  # without needing to go through Variable...
  stopifnot(is.symbol(target))
  name <- as.character(target)

  value <- args[[2]]
  value <- r2f(value, scope, ...)

  # immutable / copy-on-modify usage of Variable()
  if (is.null(var <- get0(name, scope))) {
    # this is a binding to a new symbol
    var <- value@value
    var@name <- name
    scope[[name]] <- var

  } else {
    # The var already exists, this assignment is a modification / reassignment
    check_assignment_compatible(var, value@value)
    var@modified <- TRUE
    # could probably drop this @modified property, and instead track
    # if the var populated by declare is identical at the end (e.g., perhaps by
    # address, or by attaching a unique id to each var, or ???)
    assign(name, var, scope)
  }

  Fortran(glue("{name} = {value}"))
}

r2f_handlers[["[<-"]] <- function(args, scope = NULL, ...) {

  # TODO: handle logical subsetting here, which must become a where a construct like:
  #   x[lgl] <- val
  # becomes
  # where (lgl)
  #   x = val
  # end where
  # ! but if {va} references {x}, it will only see the subset x, not the full {x}
  # e.g.,
  # sum(x) is not the same as `where lgl \n sum(x) \n end where`
  # ditto for ifelse() ?
  # e <- as.list(e)

  stopifnot(is_call(target <- args[[1L]], "["))
  target <- r2f(target, scope)

  value <- r2f(args[[2L]], scope)
  Fortran(glue("{target} = {value}"))
}

reduce_promoted_mode <- function(...) {

  getmode <- function(d) {
    if (inherits(d, Fortran))
      d <- d@value
    if (inherits(d, Variable))
      return(d@mode)
    if (is.list(d) && length(d))
      lapply(d, getmode)
  }
  modes <- unique(unlist(getmode(list(...))))

  if ("double" %in% modes)
    "double"
  else if ("integer" %in% modes)
    "integer"
  else if ("logical" %in% modes)
    "logical"
  else
    NULL

}

r2f_handlers[["="]] <- r2f_handlers[["<-"]]

r2f_handlers[["logical"]] <- function(args, scope, ...) {
  Fortran(".false.", Variable(mode = "logical", dims = r2dims(args, scope)))
}

r2f_handlers[["integer"]] <- function(args, scope, ...) {
  Fortran("0", Variable(mode = "integer", dims = r2dims(args, scope)))
}

r2f_handlers[["double"]] <- function(args, scope, ...) {
  Fortran("0", Variable(mode = "double", dims = r2dims(args, scope)))
}

r2f_handlers[["numeric"]] <- r2f_handlers[["double"]]

r2f_handlers[["character"]] <- r2f_handlers[["raw"]] <-
  .r2f_handler_not_implemented_yet

r2f_handlers[["matrix"]] <- function(args, scope = NULL, ...) {

  args$data %||% stop("matrix(data=) must be provided, cannot be NA")
  out <- r2f(args$data, scope, ...)
  out@value@dims <- r2dims(list(args$nrow, args$ncol), scope)
  out

  # TODO: reshape() if !passes_as_scalar(out)
}

conform <- function(..., mode = NULL) {
  var <- NULL
  # technically, types are implicit promoted, but we'll let <- handle that.
  for (var in drop_nulls(list(...))) {
    if (passes_as_scalar(var)) {
      next
    } else {
      break
    }
  }
  if (is.null(var))
    NULL
  else
    Variable(mode %||% var@mode, var@dims)
 }

# ---- printers ----

r2f_handlers[["cat"]] <- function(args, scope, ...) {
  args <- lapply(args, r2f, scope, ...)
  # can do a lot more here still, just a POC for now
  stopifnot(length(args) == 1, typeof(args[[1]]) == "character")
  label <- args[[1]]
  if (!endsWith(label, "\n"))
    stop("cat(<strings>) must end with '\n'")
  label <- substring(label, 1, nchar(label)-1)

  Fortran(glue('call labelpr("{label}", {nchar(label)})'))
}

r2f_handlers[["print"]] <- function(args, scope = NULL, ...) {
  # args <- lapply(as.list(e)[-1], r2f, scope)
  # args <- as.list(e)[-1]
  # can do alot more here still, just a POC for now
  stopifnot(length(args) == 1, typeof(args[[1]]) == "symbol")
  name <- args[[1]]
  var <- get(name, envir = scope)
  name <- as.character(name)
  if (var@mode == "logical")
    name <- sprintf("(%s/=0)", name)
  label <- ""
  # browser()
  if (passes_as_scalar(var)) {
    # } "scalar"
    # paste0(c(var@mode, scalar) collapse = "_"),
    printer <- switch(
      var@mode,
      logical = ,
      integer = "intpr1",
      double = "dblepr1",
      {print(var); stop("Unsupported type in print()")}
    )

    Fortran(glue('call {printer}("{label}", {nchar(label)}, {name})'))
  } else {
    printer <- switch(
      var@mode,
      logical = ,
      integer = "intpr",
      double = "dblepr",
      {print(var); stop("Unsupported type in print()")}
    )

    Fortran(glue('call {printer}("{label}", {nchar(label)}, {name}, size({name}))'))
  }
}

# r2f_handlers[["ifelse"]] <- function(e, scope) {
#   # TODO:
#   #   <- and [<- need to be aware of this construct for it to make sense.
#   .[test, yes, no] <- lapply(e[-1], r2f, scope)
#   Fortran(glue("where ({test}}
#                 {indent(yes)}
#                 elsewhere
#                 {indent({no})
#                 end where"))
# }

r2f_handlers[["length"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("size({x})"), Variable("integer"))
}
r2f_handlers[["nrow"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("size({x}, 1)"), Variable("integer"))
}
r2f_handlers[["ncol"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("size({x}, 2)"), Variable("integer"))
}
r2f_handlers[["dim"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("shape({x})"), Variable("integer", x@value@rank))
}

# this is just `[` handler
r2f_slice <- function(args, scope, ...) { }

# ---- control flow ----

r2f_handlers[["if"]] <- function(args, scope, ..., hoist = NULL) {
  # cond uses the current hoist context.
  cond <- r2f(args[[1]], scope, ..., hoist = hoist)

  # true and false branchs gets their own hoist target.
  true <- r2f(args[[2]], scope, ..., hoist = NULL)

  if (length(args) == 2) {
    Fortran(glue("
      if ({cond}) then
      {indent(true)}
      end if
      "))
  } else {
    false <- r2f(args[[3]], scope, ..., hoist = NULL)
    Fortran(glue("
      if ({cond}) then
      {indent(true)}
      else
      {indent(false)}
      end if
      "))
  }
}

# TODO: return

# ---- repeat ----
r2f_handlers[["repeat"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  body <- r2f(args[[1]], scope, ...)
  Fortran(glue(
    "do
    {indent(body)}
    end do
    "))
}

# ---- break ----
r2f_handlers[["break"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 0L)
  Fortran("exit")
}

# ---- break ----
r2f_handlers[["next"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 0L)
  Fortran("cycle")
}

# ---- while ----
r2f_handlers[["while"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 2L)
  cond <- r2f(args[[1]], scope, ...)
  body <- r2f(args[[2]], scope, ...) ## should we set a new hoist target here?
  Fortran(glue(
    "do while ({cond})
    {indent(body)}
    end do
    "))
}

## ---- for ----
r2f_iterable <- function(e, scope, ...) {
  .NotYetImplemented()

  if (is.symbol(e)) {
    var <- get(e, scope)
    iterable <- r2f(...)
  }

  # list(var, iterable, body_prefix)
}

r2f_handlers[["for"]] <- function(args, scope, ...) {
  .[var, iterable, body] <- args
  stopifnot(is.symbol(var))
  var <- as.character(var)
  scope[[var]] <- Variable(mode = "integer", name = var)

  iterable <- r2f_iterable_handlers[[as.character(iterable[[1]])]](iterable, scope)
  body <- r2f(body, scope, ...)

  Fortran(glue(
    "do {var} = {iterable}
    {indent(body)}
    end do
    "))
}

r2f_iterable_handlers := new.env()

r2f_iterable_handlers[["seq_len"]] <-  function(e, scope, ...) {
  x <- as.list(e)[-1]
  if (length(x) != 1) stop("too many args to seq_len()")
  x <- x[[1]]
  start <- 1L
  end <- r2f(x)
  glue("{start}, {end}")
}

r2f_iterable_handlers[["seq"]] <- function(e, scope) {

  ee <- match.call(seq.default, e)
  ee <- whole_doubles_to_ints(ee)

  start <- r2f(ee$from, scope)
  end <- r2f(ee$to, scope)
  step <- if (is.null(ee$by))
    glue("sign(1, {end}-{start})")
  else
    r2f(ee$by, scope)

  str_flatten_commas(
   start, end, step
  )
}

r2f_iterable_handlers[[":"]] <- function(e, scope) {

  ee <- whole_doubles_to_ints(e)
  .[start, end] <- as.list(ee)[-1] |> lapply(r2f, scope)

  glue("{start}, {end}, sign(1, {end}-{start})")
}

r2f_iterable_handlers[["seq_along"]] <- function(e, scope) {
  x <- as.list(e)[-1]
  if (length(x) != 1) stop("too many args to seq_along()")
  x <- x[[1]]
  start <- 1
  end <-  sprintf("size(%s)", r2f(x, scope))
  glue("{start}, {end}")
}

# ---- helpers ----

check_call <- function(e, nargs) {
  if (length(e) != (nargs+1L))
    stop("Too many args to: ", as.character(e[[1L]]))
}

### local variables with unspecified size are 'allocatable'. If they are bound
### to a named symbol, the manifest must mark it as allocatable.
###
### Generally, if an expression produces an array of unspecified size, even if
### it's never bound, it's still 'allocatable'. For example, an inline fortran
### `pack()` call likely still produces a corresponding `malloc()` in the
### generated code, regardless of if the output of `pack()` is bound to
### a symbol (in the case of pack specifically, the malloc is behind a
### _gfortran_pack() call.
###
### We can potentially link/mask `_malloc` and `_free` with a custom one that
### uses R_alloc(), which will automatically free after the .External() call
### returns. We can also pass along -fstack-arrays to gfortran and flang-new
### (llvm), and that will mostly get rid most of the malloc calls, instead
### allocating arrays on the C stack (which will automatically free on
### return/lngjmp), but that will run into issues with larger arrays (especially
### on windows)
###
### local vars of undefined sizes are allocatable. These will typically be
### allocated on the c stack if they are not too large, but may include a
### malloc+free call if they are large. Those might leak if we lngjmp
### away (e.g., due to an interrupt). This potential leak is a non-issue for
### now, since interrupts aren't supported yet, so there is no risk of lngjmp.
###
### When we do add support for interruptable quick functions, this potential
### leak could be guarded against by:
###
### a) linking malloc -> R_alloc() for the fortran compilation unit which
### would make the memory automatically be released after .External()
### return. Note that unlinke malloc(), R_alloc() is not thread safe, so we would need
### additional work for a `do concurrent` context to be supported.
###
### b) forcing all arrays to be stack allocated with -fstack-arrays passed
### to the gfortran/flang-new. This is not a great, since c stack limits are
### typically "small" and enforced by the OS.

r2f.scope <- function(scope) {

  vars <- as.list.environment(scope, all.names = TRUE)
  vars <- lapply(vars, function(var) {

    intent_in <- var@name %in% names(formals(scope@closure))
    intent_out <- var@name == closure_return_var_name(scope@closure) || intent_in && var@modified

    intent <-
      if (intent_in && intent_out) "intent(in out)"
      else if (intent_in) "intent(in)"
      else if (intent_out) "intent(out)"
      else NULL

    type <- switch(var@mode,
      double = "real(c_double)",
      integer = "integer(c_int)",
      complex = "complex(c_double_complex)",
      logical = if (intent_in || intent_out) "integer(c_int)" else "logical",
      raw = "integer(c_int8_t)",
      stop("unrecognized kind: ", format(var))
    )

    dims <- if (passes_as_scalar(var)) {
      NULL
    } else {
      dims2f(var@dims, scope) |> str_flatten_commas() |> sprintf(fmt = "(%s)")
    }

    allocatable <- if (!is.null(dims) && grepl(":", dims, fixed = TRUE))
      "allocatable"

    if (intent_in && intent_out && !is.null(allocatable))
      stop("all input and output vars must have a fully defined shape")

    name <- var@name
    comment <- if (var@mode == "logical") " ! logical"

    glue('{str_flatten_commas(type, intent, allocatable)} :: {name}{dims}{comment}',
         .null = "")
  })

  # vars that will be visible in the C bridge, either as an input or output
  non_local_var_names <- unique(c(names(formals(scope@closure)),
                                  closure_return_var_name(scope@closure)))

  # collect all size_names; sort so non-locals are declared first.
  size_names <- unique(unlist(lapply(non_local_var_names, function(name) {
    var <- scope[[name]]
    lapply(var@dims, all.names, functions = FALSE, unique = TRUE)
  }))) |> setdiff(names(formals(scope@closure)))

  sizes <- lapply(size_names, function(name) {
    kind <- if (endsWith(name, "_len_")) "c_ptrdiff_t" else "c_int"
    glue("integer({kind}), intent(in), value :: {name}")
  })

  manifest <- compact(list(
    sizes = sizes,
    args = vars[non_local_var_names],
    locals = vars[setdiff(names(vars), non_local_var_names)]
  ))

  manifest <- imap(manifest, \(declarations, category)
                   str_flatten_lines(paste("!", category), declarations)) |>
    str_flatten("\n\n")

  manifest <- str_flatten_lines("! manifest start", manifest, "! manifest end")

  # symbols that must come in as args to the subroutine
  # # method="radix" for locale-independent stable order.
  signature <- unique(c(non_local_var_names, sort(size_names, method = "radix")))
  attr(manifest, "signature") <- signature

  manifest
}

## fortran precedence order
##   ** (exp)
##   * /
##   + -
##
## R prededence order
##   ^
##   - +
##   %/% %%
##   * /

## generally, we just deparse() to convert an axis size.
## except for NA, which becomes ":"

dims2f_eval_base_env <- new.env(parent = emptyenv())
dims2f_eval_base_env[["("]] <- baseenv()[["("]]

# any call always evaluates to a string.
# every argument will be either:
# - NA  -> translates to ":"
# - a symbol -> translates to deparsed string
# - a call  ->

dims2f_eval_base_env[["+"]] <- function(e1, e2) glue("({e1} + {e2})")
dims2f_eval_base_env[["-"]] <- function(e1, e2) glue("({e1} - {e2})")
dims2f_eval_base_env[["*"]] <- function(e1, e2) glue("({e1} * {e2})")
dims2f_eval_base_env[["/"]] <- function(e1, e2) glue("real({e1}) / real({e2})")
# dividing integers truncates towards 0
dims2f_eval_base_env[["%/%"]] <- function(e1, e2) glue("int({e1}) / int({e2})")
dims2f_eval_base_env[["%%"]]  <- function(e1, e2) glue("mod(int({e1}), int({e2}))")
dims2f_eval_base_env[["^"]]  <- function(e1, e2) glue("({e1})**({e2})")

dims2f <- function(dims, scope) {
  syms <- unique(unlist(lapply(dims, \(d) if (is.language(d)) all.vars(d))))
  vars <- as.list(syms)
  names(vars) <- syms
  eval_env <- list2env(vars, parent = dims2f_eval_base_env)
  dims <- map_chr(dims, function(d) {
    d <- eval(d, eval_env)
    if (is.symbol(d)) as.character(d)
    else if (is_wholenumber(d)) as.character(d)
    else if (is_scalar_na(d)) ":"
    else if (is_string(d)) d
    else if (inherits(d, Variable)) {
      # a locally allocated var that is a return var
      if (!d@modified && d@is_arg)
        return(d@name)
      stop("unexpected axis size value")
    }
  })
  if (!length(dims) || identical(dims, "1")) ""
  else str_flatten_commas(dims)
}

This code segment functions to: Resolve dimension size specifications by mapping symbolic references to generated identifiers, handling numeric constants, and managing placeholder values for dynamic axis-based naming conventions.

```r
[TASK_BEGIN]
function(size, axis) {
  get_size_name(var, axis)
}
[TASK_END]
```


new_ordered_env <- function(parent = emptyenv()) {
  env <- new.env(parent = parent)
  class(env) <- "quickr_ordered_env"
  env
}

#' @export
`[[<-.quickr_ordered_env` <- function(x, name, value) {
  attr(x, "ordered_names") <- unique(c(attr(x, "ordered_names", TRUE), name))
  assign(name, value, envir = x)
  x
  # NextMethod()
}

#' @export
`[[.quickr_ordered_env` <- function(x, name) {
  get0(name, x) # name can be a symbols too
}

#' @export
names.quickr_ordered_env <- function(x) {
  all_names <- ls(envir = x, sorted = FALSE)
  ordered_names <- attr(x, "ordered_names", TRUE)
  if (!setequal(all_names, ordered_names)) {
    warning("untracked name")
    stop("untracked name")
  }
  ordered_names
}

#' @export
as.list.quickr_ordered_env <- function(x, ...) {
  out <- as.list.environment(x, all.names = TRUE, ...)
  out[names.quickr_ordered_env(x)]
}

#' @export
print.quickr_ordered_env <- function(x, ...) {
  emit("env (class: ", str_flatten_commas(class(x)), ") with bindings:")
  str(as.list.quickr_ordered_env(x), no.list = TRUE)
}

check_assignment_compatible <- function(target, value) {
  if (is.null(value)) return()
  stopifnot(exprs = {
    inherits(target, Variable)
    inherits(value, Variable)
    passes_as_scalar(target) || passes_as_scalar(value) || target@rank == value@rank
  })
}

new_scope <-

#' @export
`@.quickr_scope` <- function(x, name) attr(x, name, exact = TRUE)

#' @export
`@<-.quickr_scope` <- function(x, name, value) `attr<-`(x, name, value = value)

#' @importFrom utils .AtNames findMatches
#' @export
.AtNames.quickr_scope <- function(x, pattern = "")
  findMatches(pattern, names(attributes(x)))

function(closure, parent = emptyenv()) {
  scope <- new_ordered_env(parent = parent)
  class(scope) <- unique(c("quickr_scope", class(scope)))
  attr(scope, "closure") <- closure
  attr(scope, "get_unique_var") <- local({
    i <- 0L
    function(...) {
      name <- paste0("tmp", i <<- i + 1L, "_")
      (scope[[name]] <- Variable(..., name = name))
    }
  })
  attr(scope, "assign") <- function(name, value) {
    stopifnot(inherits(value, Variable), is.symbol(name) || is_string(name))
    name <- as.character(name)
    if (exists(name, scope))
      check_assignment_compatible(get(name, scope), value)
    value@name <- name
    assign(name, value, scope)
  }
  scope
}

#' @importFrom glue glue glue_data trim as_glue glue_collapse single_quote
#' @importFrom dotty .
#' @importFrom stats setNames
#' @importFrom utils gethash hashtab remhash sethash str
NULL

# @export
# This will be exported by S7 next release.
`:=` <- function(left, right) {
  name <- substitute(left)
  if (!is.symbol(name))
    stop("left hand side must be a symbol")

  right <- substitute(right)
  if (!is.call(right))
    stop("right hand side must be a call")

  if (is.symbol(cl <- right[[1L]]) &&
      as.character(cl) %in% c("function", "new.env")) {
    # attach "name" attr for usage like:
    # foo := function(){}
    # foo := new.env()
    right <- eval(right, parent.frame())
    attr(right, "name") <- as.character(name)
  } else {
    # for all other usage,
    # inject name as a named arg, so that
    #   foo := new_class(...)
    # becomes
    #   foo <- new_class(..., name = "foo")

    right <- as.call(c(as.list(right), list(name = as.character(name))))

    ## skip check; if duplicate 'name' arg is an issue the call itself will signal an error.
    # if (hasName(right, "name")) stop("duplicate `name` argument.")

    ## alternative code path that injects `name` as positional arg instead
    # right <- as.list(right)
    # right <- as.call(c(right[[1L]], as.character(name), right[-1L]))
  }

  eval(call("<-", name, right), parent.frame())
}

`%error%` <- function(x, y) tryCatch(x, error = function(e) y)

`append<-` <- function(x, after, value) {
  if (missing(after))
    c(x, value)
  else
    append(x, value, after = after)
}

`append1<-` <- function (x, value) {
  stopifnot(is.list(x) || identical(mode(x), mode(value)))
  x[[length(x) + 1L]] <- value
  x
}

`prepend<-` <- function(x, value) {
  c(vector(typeof(x)), value, x)
}

`add<-` <- `+` #function(x, value) x + value

map_int <- function(.x, .f, ...) vapply(X = .x, FUN = .f, FUN.VALUE = 0L, ...)
map_lgl <- function(.x, .f, ...) vapply(X = .x, FUN = .f, FUN.VALUE = TRUE, ...)
map_chr <- function(.x, .f, ...) vapply(X = .x, FUN = .f, FUN.VALUE = "", ...)

imap <- function (.x, .f, ...) {
  out <- .mapply(.f, list(.x, names(.x) %||% seq_along(.x)),
                 list(...))
  names(out) <- names(.x)
  out
}

map2 <- function (.x, .y, .f, ...) {
  if (length(.x) != length(.y) && length(.x) != 1L && length(.y) != 1L)
    stop(".x and .y must have the same length, or one of them must have length 1")
  out <- .mapply(.f, list(.x, .y), list(...))
  if (length(.x) == length(out))
    names(out) <- names(.x)
  out
}

discard <- function(.x, .f, ...)
  .x[!vapply(X = .x, FUN = .f, FUN.VALUE = TRUE, ...)]

keep <- function(.x, .f, ...)
  .x[vapply(X = .x, FUN = .f, FUN.VALUE = TRUE, ...)]

compact <- function(.x)
  .x[as.logical(lengths(.x, use.names = FALSE))]

drop_nulls <- function(x, i) {
  if (missing(i))
    x[!vapply( X = x, FUN = is.null, FUN.VALUE = FALSE, USE.NAMES = FALSE)]
  else {
    drop <- logical(length(x))
    names(drop) <- names(x)
    drop[i] <- vapply(X = x[i], FUN = is.null, FUN.VALUE = FALSE, USE.NAMES = FALSE)
    x[!drop]
  }
}

last <- function(x) x[[length(x)]]
drop_last <- function(x) x[-length(x)]

is_scalar_na      <- function(x) is.atomic(x)    && !is.object(x) && length(x) == 1L && is.na(x)
is_scalar_atomic  <- function(x) is.atomic(x)    && !is.object(x) && length(x) == 1L && !is.na(x)
is_scalar_integer <- function(x) is.integer(x)   && !is.object(x) && length(x) == 1L && !is.na(x)
is_string         <- function(x) is.character(x) && length(x) == 1L && !is.na(x) # could also be 'glue' class.
is_bool           <- function(x) is.logical(x)   && !is.object(x) && length(x) == 1L && !is.na(x)
is_number         <- function(x) is.numeric(x)   && !is.object(x) && length(x) == 1L && !is.na(x)
is_wholenumber    <- function(x) is.numeric(x)   && !is.object(x) && length(x) == 1L && !is.na(x) &&
  x >= 0L && (is.integer(x) || is.double(x) && trunc(x) == x)

new_function <- function(args = NULL, body = NULL, env = parent.frame()) {
  as.function.default(c(args, body %||% list(NULL)), env)
}

is_call <- function(x, name = NULL) {
  is.call(x) && (is.null(name) || identical(as.symbol(name), x[[1L]]))
}

str_flatten <- function(x, collapse = "") {
  paste0(as.character(unlist(x, use.names = FALSE)), collapse = collapse)
}

str_flatten_lines <- function(...) {
  paste0(unlist(c(character(), ...), use.names = FALSE), collapse = "\n")
}

str_flatten_commas <- function(...) {
  paste0(unlist(c(character(), ...), use.names = FALSE), collapse = ", ")
}

str_flatten_args <- function(..., multiline = length(dots) >= 3) {
  dots <- unlist(c(character(), ...), use.names = FALSE)
  if (multiline) {
    dots <- paste0("\n  ", dots, collapse = ",")
    paste(dots, "\n")
  } else {
    paste0(dots, collapse = ",")
  }
}

interleave <- function(x, y) {
  stopifnot(is.atomic(x), is.atomic(y), length(y) == 1L, typeof(x) == typeof(y))
  drop_last(as.vector(rbind(x, y, deparse.level = 0L)))
}

str_split_lines <- function(...) {
  x <- c(...) |>
    unlist(use.names = FALSE) |>
    strsplit("\n", fixed = TRUE)
  x[!lengths(x)] <- ""
  x |>
    unlist(use.names = FALSE) |>
    trimws("right")
}

indent <- function(x, n = 2L) {
  x <- str_split_lines(x)
  x <- sub("[ \t\r]+$", "", x, perl = TRUE) # trim trailing whitespace
  paste0(strrep(" ", n), x, collapse = "\n")
}

parent.pkg <- function(env = parent.frame(2)) {
  if (isNamespace(env <- topenv(env)))
    as.character(getNamespaceName(env)) # unname
  else
    NULL # print visible
}

set_names <- function(x, nm = x, ...) {
  names(x) <-  as.character(
    if (is.function(nm)) nm(names(x), ...)
    else unlist(list(nm, ...), use.names = FALSE)
  )
  x
}

zip_lists <- function(...) {
  x <- if (...length() == 1L) ..1 else list(...)

  if (is.character(nms.1 <- names(x.1 <- x[[1L]])))
    if (anyDuplicated(nms.1) || anyNA(nms.1) || any(nms.1 == ""))
      stop("All names must be unique.",
           " (Use `unname()` for positional matching.)")

  if (length(setdiff(lengths(x), 1L)) != 1L)
    stop("all elements must have the same length")

  for (i in seq_along(x)) {
    if (identical(nms.1, nms.i <- names(x[[i]])))
      next
    if (setequal(nms.1, nms.i)) {
      x[[i]] <- x[[i]][nms.1]
      next
    }
    stop("All names of arguments provided to `zip_lists()` must match.",
         " Call `unname()` on each argument if you want positional matching")
  }
  ans <- .mapply(list, x, NULL)
  names(ans) <- nms.1
  ans
}

is_missing <- function(x) missing(x) || identical(x, quote(expr = ))

is_type_call <- function(e) {
  is.call(e) && identical(e[[1]], quote(type))
}

reduce <- function (.x, .f, ..., .init) {
  f <- function(x, y) .f(x, y, ...)
  Reduce(f, .x, init = .init)
}

substitute_ <- function(expr, env) {
  do.call(base::substitute, list(expr, env))
}

defer <- function (expr, env = parent.frame(), after = FALSE) {
  thunk <- as.call(list(function() expr))
  do.call(on.exit, list(thunk, TRUE, after), envir = env)
}

is_scalar <- function(x) identical(length(x), 1L)

#' Compile a Quick Function
#'
#' Compile an R function.
#'
#' @param fun An R function
#' @param name Optional string, name to use for the function.
#'
#' @details
#'
#' ## `declare(type())` syntax:
#'
#' The shape and mode of all function arguments must be declared. Local and
#' return variables may optionally also be declared.
#'
#' `declare(type())` also has support for declaring size constraints, or size
#' relationships between variables. Here are some examples of declare calls:
#'
#' ```r
#' declare(type(x = double(NA))) # x is a 1-d double vector of any length
#' declare(type(x = double(10))) # x is a 1-d double vector of length 10
#' declare(type(x = double(1)))  # x is a scalar double
#'
#' declare(type(x = integer(2, 3)))  # x is a 2-d integer matrix with dim (2, 3)
#' declare(type(x = integer(NA, 3))) # x is a 2-d integer matrix with dim (<any>, 3)
#'
#' # x is a 4-d logical matrix with dim (<any>, 24, 24, 3)
#' declare(type(x = logical(NA, 24, 24, 3)))
#'
#' # x and y are 1-d double vectors of any length
#' declare(type(x = double(NA)),
#'         type(y = double(NA)))
#'
#' # x and y are 1-d double vectors of the same length
#' declare(
#'   type(x = double(n)),
#'   type(y = double(n)),
#' )
#'
#' # x and y are 1-d double vectors, where length(y) == length(x) + 2
#' declare(type(x = double(n)),
#'         type(y = double(n+2)))
#' ```
#'
#' You can provide declarations to `declare()` as:
#'
#' - Multiple arguments to a single `declare()` call
#' - Separate `declare()` calls
#' - Multiple arguments within a code block (`{}`) inside `declare()`
#'
#' ```r
#' declare(
#'   type(x = double(n)),
#'   type(y = double(n)),
#' )
#'
#' declare(type(x = double(n)))
#' declare(type(y = double(n)))
#'
#' declare({
#'   type(x = double(n))
#'   type(y = double(n))
#' })
#' ```
#'
#' ## Return values
#'
#' The shape and type of a function return value must be known at compile time.
#' In most situations, this will be automatically inferred by `quick()`. However,
#' if the output is dynamic, then you may need to provide a hint.
#' For example, returning the result of `seq()` will fail because the output shape
#' cannot be inferred.
#'
#' ```r
#' # Will fail to compile:
#' quick_seq <- quick(function(start, end) {
#'   declare({
#'     type(start = integer(1))
#'     type(end = integer(1))
#'   })
#'   out <- seq(start, end)
#'   out
#' })
#' ```
#'
#' However, if the output size can be declared as a dynamic expression using other
#' values known at runtime, compilation will succeed:
#'
#' ```r
#' # Succeeds:
#' quick_seq <- quick(function(start, end) {
#'   declare({
#'     type(start = integer(1))
#'     type(end = integer(1))
#'     type(out = integer(end - start + 1))
#'   })
#'   out <- seq(start, end)
#'   out
#' })
#' quick_seq(1L, 5L)
#' ```
#'
#' @returns A quicker R function.
#' @export
#' @examples
#' add_ab <- quick(function(a, b) {
#'   declare(type(a = double(n)),
#'           type(b = double(n)))
#'   out <- a + b
#'   out
#' })
#' add_ab(1, 2)
quick <- function(fun, name = NULL) {
  if (is.null(name)) {
    name <- if (is.symbol(substitute(fun)))
      deparse(substitute(fun))
    else
      make_unique_name(prefix = "anonymous_quick_function_")
  }

  if (nzchar(pkgname <- Sys.getenv("DEVTOOLS_LOAD"))) {
    if (!collector$is_active()) {
      if (!requireNamespace("pkgload", quietly = TRUE)) {
        stop("Please install 'pkgload'")
      }
      for (i in seq_along(sys.calls())) {
        if (identical(sys.function(i), pkgload::load_code)) {
          collector$activate(paste0(pkgname, ":quick_funcs"))
          defer(dump_collected(), sys.frame(i), after = TRUE)
          break
        }
      }
    }
  }

  if (collector$is_active()) {
    # we are in a quickr::compile_package() or a devtools::load_all() call,
    # merely collecting functions at this point.
    quick_closure <- create_quick_closure(name, fun)
    collector$add(name = name, closure = fun, quick_closure = quick_closure)
    return(quick_closure)
  }

  pkgname <- parent.pkg()
  if (!is.null(pkgname) && pkgname != "quickr") {
    # we are in a package - but outside a quickr::compile_package() call.
    return(create_quick_closure(name, fun))
  }

  # not in a package. Compile and load eagerly.
  attr(fun, "name") <- name
  fun <- compile(r2f(fun))
  attr(fun, "name") <- NULL

  fun
}

compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
  stopifnot(inherits(fsub, FortranSubroutine))

  name <- fsub@name
  c_wrapper <- make_c_bridge(fsub)

  if (dir.exists(build_dir)) unlink(build_dir, recursive = T)
  if (!dir.exists(build_dir))
    dir.create(build_dir)
  owd <- setwd(build_dir)
  on.exit(setwd(owd))

  fsub_path <- paste0(name, "_fsub.f90")
  c_wrapper_path <- paste0(name, "_c_wrapper.c")
  dll_path <- paste0(name, .Platform$dynlib.ext)
  writeLines(fsub, fsub_path)
  writeLines(c_wrapper, c_wrapper_path)

  suppressWarnings({
    result <- system2(
      R.home("bin/R"),
      c("CMD SHLIB --use-LTO", "-o", dll_path, fsub_path, c_wrapper_path),
      stdout = TRUE, stderr = TRUE
    )
  })
  if (!is.null(attr(result, "status"))) {
    writeLines(result, stderr())
    str(attributes(result))
    stop("Compilation Error")
  }

  # tryCatch(dyn.unload(dll_path), error = identity)
  dll <- dyn.load(dll_path)
  c_wrapper_name <- paste0(fsub@name, "_")
  ptr <- getNativeSymbolInfo(c_wrapper_name, dll)$address

  create_quick_closure(fsub@name, fsub@closure, native_symbol = ptr)
}

create_quick_closure <- function(name, closure,
                                 native_symbol = as.name(paste0(name, "_"))) {
  body(closure) <- as.call(c(quote(.External), native_symbol,
                             lapply(names(formals(closure)), as.name)))
  closure
}

check_all_var_names_valid <- function(fun) {
  nms <- unique(c(names(formals(fun)), all.vars(body(fun), functions = FALSE)))
  invalid <- endsWith(nms, "_") | startsWith(nms, "_") | nms %in% c(

    # clashes with Fortran subroutine symbols
    "c_int", "c_double", "c_ptrdiff_t",

    # clashes with C bridge symbols
    "int" #, "double",

    # ??? (clashes with R symbols?)
    # "double", "integer"
  )
  if (any(invalid)) {
    stop("symbols cannot start or end with '_', but found: ",
         glue_collapse(invalid, ", ", last = ", and "))
  }
}

# ---- utils ----

make_unique_name <- local({
  i <- 0L
  function(prefix = "tmp") {
    paste0(prefix, i <<- i + 1L)
  }
})

#' @import S7
NULL

new_setter <- function(coerce = NULL, coerce_null = FALSE, set_once = FALSE, env = parent.frame(2L)) {

  if (is.null(coerce) || isFALSE(coerce) && isFALSE(set_once))
    return()

  bind_name <- quote(name <- as.character(last(attr(self, ".setting_prop", TRUE))))

  check_set_once <- if (set_once) {
    quote(if (!is.null(prop(self, name)))
      stop(name, " can only be set once"))
  }

  rebind_coerced_value <-
    if (is.null(coerce) || isFALSE(coerce)) {
      NULL
    } else if (isTRUE(coerce)) {
      quote(value <- convert(
        from = value,
        to = S7_class(self)@properties[[as.character(name)]]$class
      ))
    } else if (is.function(coerce) || is.symbol(coerce)) {
      bquote(value <- .(coerce)(value))
    } else if (is.language(coerce)) {
      bquote(value <- .(coerce))
    } else {
      stop("coerce must be TRUE, FALSE, NULL, a function, a symbol, or a call")
    }

  if (!coerce_null && !is.null(rebind_coerced_value)) {
    rebind_coerced_value <- bquote(if (!is.null(value)) .(rebind_coerced_value))
  }

  set <- quote(`prop<-`(
    object = self,
    name = name,
    check = FALSE,
    value = value
  ))

  new_function(
    args = alist(self = , value = ),
    body = as.call(c(quote(`{`),
      bind_name,
      check_set_once,
      rebind_coerced_value,
      set)),
    env = env
  )
}

new_scalar_validator <- function(allow_null = FALSE,
                                 allow_na = FALSE,
                                 additional_checks = NULL,
                                 env = parent.frame(2L)) {
  checks <- c(
    if (allow_null) quote(if (is.null(value)) return()),
    quote(if (length(value) != 1L) return("must be a scalar")),
    if (!allow_na) quote(if (anyNA(value)) return("must not be NA")),
    additional_checks
  )

  new_function(
    args = alist(value = ),
    body = as.call(c(quote(`{`), checks)),
    env = parent.frame(2L)
  )
}

prop_bool <- function(default, allow_null = FALSE, allow_na = FALSE, set_once = FALSE) {
  stopifnot(is_bool(set_once), is_bool(allow_null), is_bool(allow_na))

  new_property(
    class = if (allow_null) NULL | class_logical else class_logical,
    setter = new_setter(set_once = set_once),
    validator = new_scalar_validator(allow_null = allow_null,
                                     allow_na = allow_na),
    default = default
  )
}

prop_string <- function(default = NULL,
                        allow_null = FALSE,
                        allow_na = FALSE,
                        coerce = FALSE,
                        set_once = FALSE) {
  stopifnot(is_bool(set_once), is_bool(allow_null), is_bool(allow_na))

  if (isTRUE(coerce))
    coerce <- quote(as.character)

  new_property(
    class = if (allow_null) NULL | class_character else class_character,
    default = default,
    validator = new_scalar_validator(allow_null = allow_null),
    setter = new_setter(coerce = coerce,
                        coerce_null = !allow_null,
                        set_once = set_once)
  )
}

prop_wholenumber <- function(default = NULL,
                             allow_null = FALSE,
                             allow_na = FALSE,
                             coerce = TRUE,
                             set_once = FALSE) {
  stopifnot(is_bool(set_once), is_bool(allow_null), is_bool(allow_na))

  if (isTRUE(coerce))
    coerce <- quote(
      if (is_wholenumber(value)) as.integer(value)
      else stop("@", name, " must be a whole number, but received: ", value)
      )

  new_property(
    class = if (allow_null) NULL | class_integer else class_integer,
    default = as.integer(default),
    setter = new_setter(coerce = coerce,
                        coerce_null = !allow_null,
                        set_once = set_once),
    validator = new_scalar_validator(allow_null = allow_null)
  )
}

prop_enum <- function(values,
                      nullable = FALSE,
                      default = if (nullable) NULL else values[1],
                      exact = FALSE,
                      set_once = FALSE) {

  stopifnot(
    "values must be a character vector of length >= 2 without any NA" =
      is.character(values) && length(values) >= 2 && !anyNA(values)
  )

  coerce <- if (exact) NULL else {
    bquote(if (length(value) == 1L && !anyNA(i <- charmatch(value, .(values))))
      .(values)[i] else value)
  }

  display_values <- glue_collapse(single_quote(values), sep = ", ", last = ", or ")
  msg <- sprintf("must be either %s, not '", display_values)
  validator <- new_scalar_validator(allow_null = nullable,
                                    additional_checks = bquote(
    if (!match(value, .(values), nomatch = 0L))
      return(paste0(.(msg), value, "'."))
  ))

  new_property(
    class = if (nullable) NULL | class_character else class_character,
    setter =  new_setter(coerce = coerce, coerce_null = !nullable, set_once = set_once),
    validator = validator,
    default = default
  )
}

.atomic_type_names <- c("integer", "logical", "double",
                        "character", "raw", "complex")

# the print method for this should only print non-null values
Variable := new_class(
  properties = list(

    mode = prop_enum(.atomic_type_names, nullable = TRUE, set_once = FALSE),

    dims = new_property(
      # NULL means scalar
      NULL | class_list,
      setter = function(self, value) {
        if (!length(value))
          return(self)

        value <- switch(typeof(value),
          logical = , integer = , double = as.list(value),
          language = , symbol = list(value), # implicit rank-1
          list = value,
          stop("@dims must be a list")
        )

        value <- lapply(value, \(axis) {
          if (is.language(axis)) {
            axis
          } else if (is_wholenumber(axis) || is_scalar_na(axis)) {
            as.integer(axis)
          } else {
            stop(sprintf(
              "%s@dims must be a list of language or scalar integers, not %s",
              self@name %||% '', axis
            ))
          }
        })

        self@dims <- value
        self
      } # dims$setter
    ), # dims = new_property()

    name = prop_string(
      allow_null = TRUE,
      coerce = quote(switch(typeof(value), symbol = as.character(value), value)),
      set_once = FALSE #TRUE
    ),

    rank = new_property(
      class_integer,
      getter = function(self) {
        length(self@dims)
      }),

    modified = prop_bool(default = FALSE),

    r = new_property(
      NULL | class_language | class_atomic,
      setter = function(self, value) {
        # custom setter to workaround https://github.com/RConsortium/S7/issues/511
        attr(self, "r") <- value
        self
      }
    ),

    is_arg = prop_bool(default = FALSE),

    is_return = prop_bool(default = FALSE),

    # TRUE for closure args and return values, FALSE for all other vars.
    is_external = new_property(
      class_logical,
      getter = function(self)
        self@is_arg || self@is_return
    ),

    is_scalar = new_property(
      class_logical,
      getter = function(self) {
        self@rank == 0 || identical(self@dims, list(1L))
      }
    )

    )
)

# method(print, Variable) <- function(x, ...) {
#
# }

Fortran := new_class(
  class_character,

  properties = list(

    value = NULL | Variable,

    r = new_property(
      # custom setter only to workaround https://github.com/RConsortium/S7/issues/511
      NULL | class_language | class_atomic,
      setter = function(self, value) {
        attr(self, "r") <- value
        self
      }
    )
  ),

  validator = function(self) {
    if (length(self) != 1L)
      "must be a length 1 string"
  }
)

FortranSubroutine := new_class(Fortran, properties = list(
  name = prop_string(),
  signature = class_character,
  closure = class_function,
  scope = NULL | class_environment,
  c_bridge = S7::new_property(
    NULL | class_character,
    getter = function(self) {
      make_c_bridge(self) %error% NULL
    })
))

`%error%` <- function(x, y) tryCatch(x, error = function(e) y)

try_prop <- function(object, name) S7::prop(object, name) %error% NULL

emit <- function(..., sep = "", end = "\n") cat(..., end, sep = sep)

method(format, Variable) <- function(x, ...) {
  capture.output(str(x))
}

method(as.character, Variable) <- function(x, ...)
  x@name %||% stop("Variable does not have a name")

method(print, Fortran) <- function(x, ...) {
  emit(trimws(x), end = "\n\n")
  for(prop_name in c("value", "r", "c_bridge"))
    if (!is.null(prop_val <- try_prop(x, prop_name))) {
      emit("@", prop_name, ": ", trimws(indent(format(prop_val))));
    }
}

#' Compile all `quick()` functions in a package.
#'
#' This will compile all `quick()` functions in an R package, and
#' generate source files in the `src/` directory.
#'
#' Note, this function is automatically invoked during a `pkgload::load_all()` call.
#'
#' @param path Path to an R package
#'
#' @returns Called for its side effect.
#' @export
compile_package <- function(path = ".") {
  if (path != ".") {
    owd <- setwd(path)
    on.exit(setwd(owd), add = TRUE)
  }

  if (!dir.exists("R") || !file.exists("DESCRIPTION"))
    stop(path, " does not appear to be an R package.")

  pkgname <- read.dcf("DESCRIPTION", "Package")
  if (length(pkgname) != 1)
    stop(sprintf("path '%s' does not point to an R package", path))
  pkgname <- as.character(pkgname)

  # collect all `quick()` calls in the package
  collector$activate(paste0(pkgname, ":quick_funcs"))

  # TODO: need to unset various R_* env vars, or just
  # take a dep on callr
  system2(file.path(R.home("bin"), "R"),
          c("-q", "-e", shQuote("pkgload::load_all()")))
}

dump_collected <- function() {

  collected <- collector$get_collected()

  # try to resolve closure names for anonymous functions
  pkg_ns <- topenv(environment(collected[[1L]]$closure))
  pkg_funcs <- as.list.environment(pkg_ns, all.names = TRUE)
  tab <- hashtab("address", length(collected))
  for (i in seq_along(pkg_funcs)) {
    if (typeof(fn <- pkg_funcs[[i]]) == "closure")
      # if is quick closure ...
      sethash(tab, pkg_funcs[[i]], names(pkg_funcs)[i])
  }

  quick_funcs <- unlist(recursive = FALSE, lapply(collected, function(x) {
    if (!startsWith(x$name, "anonymous_quick_function_"))
      return(setNames(list(x$closure), x$name))
    true_name <- gethash(tab, x$quick_closure)
    if (is.null(true_name))
      return(setNames(list(x$closure), x$name))
    # update pkg_ns with true name
    quick_closure <- create_quick_closure(true_name, x$closure)
    pkg_ns[[true_name]] <- quick_closure
    remhash(tab, x$quick_closure)
    setNames(list(x$closure), true_name)
  }))

  pkgname <- basename(normalizePath("."))

  # check if we have a useDynLib line in NAMESPACE.
  if (!any(sapply(parse(file = "NAMESPACE"), function(e) {
    identical(e[[1]], quote(useDynLib)) && isTRUE(e$.registration)
  })))
    message("- Please add this roxygen directive somewhere in the Package R sources:\n  ",
            glue("#' @useDynLib {pkgname}, .registration = TRUE"), "\n",
            "- Then run `devtools::document()`\n")

  sources <- zip_lists(imap(quick_funcs, function(func, name) {
    fsub <- new_fortran_subroutine(name, func)
    cbridge <- make_c_bridge(fsub, headers = name == names(quick_funcs)[1])
    list(f90 = fsub, c = cbridge)
  })) |> lapply(\(x) x |> unlist() |> interleave("\n"))

  entries <- paste0(sprintf('  {"%1$s", (DL_FUNC) &%1$s, -1}',
                            paste0(names(quick_funcs), "_")),
                    collapse = ",\n")
  entries <- sprintf("static const R_ExternalMethodDef QuickrEntries[] = {\n%s\n};",
                     entries)

  append(sources$c) <- c("", entries, "")

  R_init_pkg <- paste0("R_init_", pkgname, "(")
  has_pkg_init_fn <- list.files("src", pattern = "\\.(c|cpp|h|hpp|c\\+\\+)$",
                                recursive = TRUE, all.files = TRUE,
                                full.names = TRUE) |>
    setdiff("src/quickr_entrypoints.c") |>
    lapply(function(f) {
      any(grepl(R_init_pkg, readLines(f, warn = FALSE), fixed = TRUE))
    }) |> unlist() |> any()

  append(sources$c) <- c("#include <R_ext/Rdynload.h>", "")

  init_fn <- if (has_pkg_init_fn) {
    glue("
      void R_init_{pkgname}_quick_functions(DllInfo *dll) {{
        R_registerRoutines(dll, NULL, NULL, NULL, QuickrEntries);
      }}")
  } else {
    init_pkgname <- gsub(".", "_", pkgname, fixed = TRUE)
    glue("
      void R_init_{init_pkgname}(DllInfo *dll) {{
        R_registerRoutines(dll, NULL, NULL, NULL, QuickrEntries);
        R_useDynamicSymbols(dll, FALSE);
      }}")
  }

  append(sources$c) <- init_fn

  sources <- lapply(sources, str_split_lines)

  src_files_written <- FALSE
  if (!file.exists("src")) dir.create("src")
  cbridges_filepath <- "src/quickr_entrypoints.c"
  if (!file.exists(cbridges_filepath) || !identical(sources$c, readLines(cbridges_filepath))) {
    unlink(sprintf("%s.o", tools::file_path_sans_ext(cbridges_filepath)))
    unlink(pkg_dll_path(pkgname)) # TODO: this might fail on windows - need a fallback.
    writeLines(sources$c, cbridges_filepath)
    cli::cli_inform(c(i = "Updated {.file {cbridges_filepath}}"))
    src_files_written <- TRUE
  }

  fsubs_filepath <- "src/quickr_sub_routines.f90"
  if (!file.exists(fsubs_filepath) || !identical(sources$f90, readLines(fsubs_filepath))) {
    unlink(sprintf("%s.o", tools::file_path_sans_ext(fsubs_filepath)))
    unlink(pkg_dll_path(pkgname)) # TODO: this might fail on windows - need a fallback.
    writeLines(sources$f90, fsubs_filepath)
    cli::cli_inform(c(i = "Updated {.file {fsubs_filepath}}"))
    src_files_written <- TRUE
  }

  if (src_files_written) {
    for (i in seq_along(sys.calls())) {
      if (identical(sys.function(i), pkgload::load_all)) {
        defer(pkgload::load_all(), sys.frame(i), after = TRUE)
        rlang::return_from(sys.frame(i), value = invisible())
        break
      }
    }
  }
  invisible()
}

pkg_dll_path <- function (pkgname) {
  file.path("src", paste0(pkgname, .Platform$dynlib.ext))
}

collector <- local({

  .collected <- NULL

  activate <- function(name = NULL) {
    .collected <<- list()
    attr(.collected, "name") <<- name
  }

  is_active <- function() {
    is.list(.collected)
  }

  add <- function(...) {
    .collected[[length(.collected)+1L]] <<- list(...)
  }

  get_collected <- function(clear = TRUE) {
    if (clear)
      on.exit(.collected <<- NULL)
    .collected
  }

  environment()
})

check_type_call <- function(cl) {
  if (length(cl) > 2)
    stop("only one variable can be declared per type() call")
  args <- as.list(cl)[-1]
  if (length(names(args)) != 1)
    stop("name must be provided as: type(<name> = <mode>(<<dims>>)")
  if (!is.call(args[[1]]) && as.character(args[[1]]) %in% .atomic_type_names)
    stop("only atomic modes are supported")
}

type_call_to_var <- function(cl) {
  check_type_call(cl)
  Variable(
    name = names(cl)[-1],
    mode = as.character(cl[[2L]][[1L]]),
    dims = unname(as.list(cl[[2]])[-1])
  )
}

var_to_type_call <- function(var) {
  arg <- as.call(c(as.symbol(var@mode), var@dims))
  arg <- setNames(list(arg), var@name)
  as.call(c(quote(type), arg))
}

get_flattened_args <- function(cl) {
  # flatten exprs from `{` in usage like declare({ ... })`
  args <- as.list(cl)[-1]
  args <- lapply(args, function(e) {
    if (is_missing(e))
      NULL
    else if (is_call(e, quote(`{`)))
      get_flattened_args(e)
    else
      list(e)
  })
  unlist(args, recursive = FALSE)
}

self_evaluate <- function(...) sys.call()

substitute_declared_sizes <- function(e) {
  stopifnot(is_call(e, quote(`{`)))

  aliases <- new.env(parent = emptyenv())
  eval_env <- new.env(parent = emptyenv())
  for(name in all.names(e, functions = TRUE, unique = TRUE))
    assign(name, self_evaluate, eval_env)
  eval_env <- new.env(parent = eval_env)
  for(name in all.names(e, functions = FALSE, unique = TRUE))
    assign(name, as.symbol(name), eval_env)

  eval_env$`{` <- function(...) {
    as.call(c(list(quote(`{`)), list(...)))
  }

  eval_env$declare <- function(...) {
    args <- get_flattened_args(sys.call())
    args <- lapply(args, function(e) {
      if (is_type_call(e)) {
        var <- type_call_to_var(e)
        var@dims <- imap(var@dims, function(size, axis) {
          size_name <- as.symbol(get_size_name(var, axis))
          if (is.symbol(size) && !exists(size, aliases)) {
            # user defined implicit size_name alias
            assign(as.character(size), size_name, aliases)
            size <- size_name
          } else if (is_scalar_na(size)) {
            size <- size_name
          } else if (is_wholenumber(size)) {
            size <- as.integer(size)
          }
          size
        })
        e <- var_to_type_call(var)
      }
      e
    })

    as.call(c(quote(declare), args))
  }

  e <- eval(e, eval_env)

  # Now the 'aliases' env is populated; go through and substitute
  # size aliases with the actual size name.
  eval_env$declare <- function(...) {
    as.call(lapply(sys.call(), function(e) {
      if (is_type_call(e))
        e <- substitute_(e, aliases)
      e
    }))
  }

  eval(e, eval_env)

}

r2size <- function(r, scope) {
  typeof(r) |> switch(
    integer = r,
    double = {
      if (is_wholenumber(r))
        as.integer(r)
      else
        stop("size must be an integer, found: ", r)
    },
    symbol = {
      if (is_size_name(r))
        return(r)
      var <- get(r, scope)
      if (var@mode != "integer" || !passes_as_scalar(var))
        warning("size is not an integer:", as.character(r))
      if (var@is_arg && !var@modified)
        return(r)
      # TODO: add specific unit tests here
      if (identical(var@r, r))
        return(r)
      # make a best effort to use the r expression last assigned to the
      # symbol, or fail gracefully and return NA.
      # closure-locals with unspecified shape are declared allocatable
      # input and/or output args with unspecified shape signal an error.
      r2size(var@r, scope)
    },
    language = {
      as.character(r[[1]]) |> switch(
        `+` = , `-` = , `/` = , `*` = , `^` = , `%/%` = , `%%` = {
          args <- as.list(r)[-1]
          args <- lapply(args, r2size, scope)
          if (anyNA(rapply(args, as.list)))
            return(NA_integer_)
          cl <- as.call(c(r[[1]], args))
          if (all(map_lgl(args, is.atomic)))
            cl <- eval(cl, baseenv())
          cl
        },
        length = {
          var <- get(r[[2L]], scope)
          if (var@rank == 1)
            return(var@dims[[1L]])
          len <- reduce(var@dims, \(d1, d2) call("*", d1, d2))
          r2size(len, scope)
        },
        `[` = {
          # [ only works when paired with dim()
          if (!is_call(r[[2L]], quote(dim)))
            return(NA_integer_)
          var <- get(r[[2L]][[2L]], scope)
          axis <- r[[3]]
          if (!is_wholenumber(axis))
            return(NA_integer_)
          if (axis > var@rank)
            stop("insufficient rank of variable in ", deparse1(r))
          var@dims[[axis]]
        },
        # dim = {
        #
        # },
        nrow = {
          var <- get(r[[2L]], scope)
          var@dims[[1]]
        },
        ncol = {
          var <- get(r[[2L]], scope)
          var@dims[[2]]
        },
        NA_integer_)
    },
    NA_integer_
  )
}

r2dims <- function(r, scope) {
  if (is.call(r)) {
    as.character(r[[1]]) |> switch(
      dim = {
        var <- get(r[[2L]], scope)
        return(var@dims)
      },
      c = {
        args <- lapply(r[-1], r2dims, scope)
        dims <- unlist(args, recursive = FALSE)
        return(as.list(dims))
      },
      r <- list(r))
  }
  lapply(r, r2size, scope)
}

get_size_name <- function(var, axis = NULL, name = var@name, rank = var@rank) {
  stopifnot(is.null(axis) || is_wholenumber(axis) && axis > 0)
  if (is.null(axis) || rank == 1 && axis == 1)
    sprintf("%s__len_", name)
  else {
    if (axis > rank) stop("axis must not be > rank")
    sprintf("%s__dim_%i_", name, axis)
  }
}

# TODO: allow syntax like:
#   declare(type(a, b, c = integer(1)))
# or:
#   declare(type(a = , b = , c = integer(1)))

make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
  stopifnot(inherits(fsub, FortranSubroutine))

  closure <- fsub@closure
  scope <- fsub@scope

  fsub_arg_names <- fsub@signature # arg names
  closure_arg_names <- names(formals(closure))

  c_body <- character()

  if (!all(closure_arg_names %in% fsub_arg_names))
    stop("Undeclared arguments: ", str_flatten_commas(setdiff(closure_arg_names, fsub_arg_names)))

  closure_arg_vars <- mget(closure_arg_names, scope)

  # first unpack all the input vars into named C variables (including sizes and pointer)
  append(c_body) <- lapply(closure_arg_vars, closure_arg_c_defs, strict = strict) |>
    rbind("")

  ## TODO, might still need to define a length size for vars where rank>1, if in checks.

  # now do all size checks.
  append(c_body) <- lapply(closure_arg_vars, closure_arg_size_checks, scope = scope)

  # maybe define and allocate the output var
  n_protected <- 0L
  return_var <- get(closure_return_var_name(closure), scope)
  if (!return_var@name %in% closure_arg_names) {
    return_var@modified <- TRUE
    assign(return_var@name, return_var, scope)
    append(c_body) <- return_var_c_defs(return_var, fsub@scope)
    add(n_protected) <- 1L # allocated return var
    if (return_var@rank > 1)
      add(n_protected) <- 1L # allocated _dim_sexp
  }

  fsub_call_args <- fsub_arg_names |>
    lapply(\(nm) paste0(nm, if (!is_size_name(nm)) "__")) |>
    unlist()

  if (length(fsub_call_args) > 3)
    fsub_call_args <- paste0("\n  ", fsub_call_args)

  append(c_body) <- c("", glue("{fsub@name}({str_flatten_commas(fsub_call_args)});"), "")
  if (n_protected > 0)
    append(c_body) <- glue("UNPROTECT({n_protected});")
  append(c_body) <- glue("return {return_var@name};")

  c_args <- paste("SEXP", names(formals(closure)), collapse = ", ")
  c_body <- as_glue(str_flatten_lines(c_body))

  c_func_def <- glue("SEXP {fsub@name}_(SEXP _args) {c_block(c_body)}")

  fsub_extern_decl <- fsub_extern_decl(fsub)

  c_headers <- glue::trim(r"--(
     #define R_NO_REMAP
     #include <R.h>
     #include <Rinternals.h>

     )--")

  as_glue(str_flatten_lines(c(
    if (headers) c_headers,
    fsub_extern_decl, "",
    c_func_def)
  ))
}

closure_arg_c_defs <- function(var, strict = TRUE) {

  name <- var@name
  mode <- var@mode

  c_code <- character()

  name <- var@name
  SEXPTYPE <- sexptype(var@mode)
  protect <- glue("SETCAR(_args, {var@name});")

  append(c_code) <- glue(
    "// {name}
    _args = CDR(_args);
    SEXP {var@name} = CAR(_args);")

  # first maybe duplicate or coerce the SEXP if needed.
  append(c_code) <- glue("if (TYPEOF({name}) != {SEXPTYPE}) {{")
  append(c_code) <- indent(if (strict) {
    glue(r"(
      Rf_error("typeof({name}) must be '{mode}', not '%s'", R_typeToChar({name}));
      )")
  } else {
    glue("{name} = Rf_coerceVector({name}, {SEXPTYPE});
         {protect}")
  })

  if (var@modified) {
    dup <- glue('
      {name} = Rf_duplicate({name});
      {protect}
      ')

    if (strict) {
      append(c_code) <- c("}", dup)
    } else {
      append(c_code) <- sprintf("} else %s", dup)
    }

  } else {
    append(c_code) <- "}"
  }

  # define the variable that will be passed to the fsub
  append(c_code) <- glue(
    "{fsub_arg_var_c_type(var)} {name}__ = {sexpdata(var@mode)}({name});")

  if (var@rank == 1) {
    size_name <- get_size_name(var)
    append(c_code) <- glue("const R_xlen_t {size_name} = Rf_xlength({var@name});")
  } else if (var@rank > 1) {
    append(c_code) <- glue(
      'const int* const {var@name}__dim_ = ({{
         SEXP dim_ = Rf_getAttrib({var@name}, R_DimSymbol);
         if (Rf_length(dim_) != {var@rank}) Rf_error(
           "{var@name} must be a {var@rank}D-array, but length(dim({var@name})) is %i",
           (int) Rf_length(dim_));
         INTEGER(dim_);}});'
    )
    append(c_code) <- map_chr(seq_len(var@rank), \(axis) {
      size_name <- get_size_name(var, axis)
      glue("const int {size_name} = {var@name}__dim_[{axis-1}];")
    })
  } else {
    stop("bad rank")
  }

  as_glue(str_flatten_lines(c_code))
}

closure_arg_size_checks <- function(var, scope) {
  imap(var@dims, function(d, axis) {
    # axis is either:
    #  - an integer
    #  - a symbol of a size_name
    #  - a call, consisting of only size_name symbols and basic arithmetic ops.
    size_name <- get_size_name(var, axis)

    if (is_scalar_integer(d)) {
      return(glue('
          if ({size_name} != {d})
            Rf_error("{friendly_size(var, axis)} must be {d}, not %0.f",
                      (double){size_name});'
      ))
    }

    if (is.symbol(d)) {
      if (as.character(d) == size_name) {
        # self-named size_name is expected to be passed along to subroutine
        return()
      } else {
        # it's a constraint for another size
        return(glue('
            if ({d} != {size_name})
              Rf_error("{as_friendly_size_name(size_name)} must equal {as_friendly_size_name(d)},"
                       " but are %0.f and %0.f",
                        (double){size_name}, (double){d});'
        ))
      }
    }

    if (is.call(d)) {
      size.c <- dims2c(list(d), scope)
      return(glue('{{
          const R_xlen_t expected = {size.c};
          if ({size_name} != expected)
            Rf_error("{as_friendly_size_name(size_name)} must equal {as_friendly_size_expression(d)},"
                     " but are %0.f and %0.f",
                      (double){size_name}, (double)expected);
        }}'
      ))
    }

    stop("bad dim")
  })
}

return_var_c_defs <- function(var, scope) {
  # allocate the return var.
  name <- var@name
  c_dims <- dims2c(var@dims, scope)
  c_len <- c_dims2c_len(c_dims)
  len_name <- get_size_name(var)

  c_code <- c(
    glue("const R_xlen_t {len_name} = {c_len};"),
    glue(switch(
      var@mode,
      double = "
        SEXP {name} = PROTECT(Rf_allocVector(REALSXP, {len_name}));
        double* {name}__ = REAL({name});",
      integer = "
        SEXP {name} = PROTECT(Rf_allocVector(INTSXP, {len_name}));
        int* {name}__ = INTEGER({name});",
      complex = "
        SEXP {name} = PROTECT(Rf_allocVector(CPLXSXP, {len_name}));
        Rcomplex* {name}__ = COMPLEX({name});",
      logical = "
        SEXP {name} = PROTECT(Rf_allocVector(LGLSXP, {len_name}));
        int* {name}__ = LOGICAL({name});"
    )))

  if (var@rank > 1) {
    append(c_code) <- c_block(
      glue("
        const SEXP _dim_sexp = PROTECT(Rf_allocVector(INTSXP, {var@rank}));
        int* const _dim = INTEGER(_dim_sexp);"
      ),
      imap(c_dims, function(d, i) {
        glue("_dim[{i-1}] = {d};")
      }),
      glue("Rf_dimgets({var@name}, _dim_sexp);")
    )
  }

  str_flatten_lines(c_code)
}

dims2c_eval_base_env <- new.env()

dims2c_eval_base_env[["("]]   <- baseenv()[["("]]
dims2c_eval_base_env[["+"]]   <- function(e1, e2) glue("({e1} + {e2})")
dims2c_eval_base_env[["-"]]   <- function(e1, e2) glue("({e1} - {e2})")
dims2c_eval_base_env[["*"]]   <- function(e1, e2) glue("({e1} * {e2})")
dims2c_eval_base_env[["/"]]   <- function(e1, e2) glue("((double)({e1}) / (double)({e2}))")
# dividing integers truncates towards 0
dims2c_eval_base_env[["%/%"]] <- function(e1, e2) glue("((R_xlen_t){e1} / (R_xlen_t){e2})")
dims2c_eval_base_env[["%%"]]  <- function(e1, e2) glue("((R_xlen_t){e1} % (R_xlen_t){e2})")
dims2c_eval_base_env[["^"]]   <- function(e1, e2) glue("({e1}**{e2})")

dims2c <- function(dims, scope) {
  if (!length(dims) || identical(dims, list(1L))) {
    return(list(NULL, "1"))
  }

  syms <- as.character(unique(unlist(lapply(dims, all.vars))))

  syms <- mget(syms, scope, ifnotfound = syms) |>
    lapply(function(var) {
      if (is_size_name(var)) {
        return(as.character(var))
      }
      # resolve a variable from scope (i.e., some other arg var)
      if (!inherits(var, Variable))
        stop("could not resolve size: ", var)
      glue("Rf_asInteger({var@name})")
      # Should this be as double?
      # TODO: force this into a named c var, to avoid repeated calls
    })

  eval_env <- list2env(syms, parent = dims2c_eval_base_env)
  c_dims <- lapply(dims, function(d) {
    if (inherits(d, Variable))
      return(glue("Rf_asInteger({d@name})"))
    eval(d, eval_env)
  })

  c_dims
}

c_dims2c_len <- function(c_dims) {
  if (length(c_dims) == 1)
    c_dims[[1L]]
  else
    paste0("(", unlist(c_dims), ")", collapse = " * " )
  # eval(Reduce(\(a, b) { call("*", as.symbol(a@name), as.symbol(b@name)) }, dims),
  #      eval_env)
}

# --- utils ----

c_block <- function(...) {
  as_glue(paste0(c("{", indent(c(...)), "}"), collapse = "\n"))
}

# is_var_size <- function(x) inherits(x, VariableSize)

passes_as_scalar <- function(var) {
  var@rank == 0 || var@rank == 1 && identical(var@dims, list(1L))
}

passes_as_value <- function(var) {
  passes_as_scalar(var) && isFALSE(var@modified)
}

sexptype <- function(mode) {
  switch(mode,
         integer = "INTSXP",
         double = "REALSXP",
         complex = "CPLXSXP",
         logical = "LGLSXP",
         stop("Unrecognized mode: ", mode))
}

sexpdata <- function(mode) {
  switch(mode,
         integer = "INTEGER",
         double = "REAL",
         complex = "COMPLEX",
         logical = "LOGICAL",
         stop("Unrecognized mode: ", mode))
}

is_size_name <- function(name) {
  if (is.symbol(name)) {
    name <- as.character(name)
  } else if (!is_string(name)) {
    return(FALSE)
  }

  grepl("(_len_|_dim_[0-9]+_)$", name)
}

friendly_size <- function(var, axis = NULL) {
  if (is.null(axis) || var@rank == 1 && axis == 1)
    glue("length({var@name})")
  else
    glue("dim({var@name})[{axis}]")
}

as_friendly_size_name <- function(size_name) {
  size_name <- as.character(size_name)
  if (endsWith(size_name, "__len_"))
    sprintf("length(%s)", sub("__len_$", "", size_name))
  else
    sub("^(.*)__dim_([0-9]+)_$", "dim(\\1)[\\2]", size_name)
}

as_friendly_size_expression <- function(d) {
  stopifnot(is.call(d))
  nms <- all.names(d, functions = FALSE, unique = TRUE)
  friendly_substitutions <- new.env(parent = emptyenv())
  for(name in nms)
    if (is_size_name(name))
      assign(name, str2lang(as_friendly_size_name(name)), friendly_substitutions)
  d <- substitute_(d, friendly_substitutions)
  d <- call("(", d)
  deparse1(d)
}

closure_return_var_name <- function(closure) {
  return_var_name <- last(body(closure))
  if (!is.symbol(return_var_name))
    stop("return value must be a symbol")
  as.character(return_var_name)
}

fsub_arg_var_c_type <- function(var) {
  type <- switch(var@mode,
    double  = "double*",
    integer = "int*",
    complex = "Rcomplex*",
    logical = "int*",
  )

  # the first const declares that the pointed to values can't be modified
  #   (the array values are read only)
  # the second const declares that the pointer itself can't be modified
  #   (the fsub can never move/reallocate the array, so this const is always present)
  paste0(c(if (!var@modified) "const", type, "const"),
         collapse = " ")
}

fsub_extern_decl <- function(fsub) {
  fsub_arg_names <- fsub@signature # arg names
  scope <- fsub@scope

  fsub_c_sig <- map_chr(fsub_arg_names, function(name) {
    if (is_size_name(name)) {
      type <- if (endsWith("__len_", name))
        "R_xlen_t" else "R_len_t"
      glue("const {type} {name}")
    } else {
      var <- get(name, fsub@scope)
      glue("{fsub_arg_var_c_type(var)} {var@name}__")
    }
  })
  if (length(fsub_c_sig) >= 3L)
    fsub_c_sig <- paste0("\n  ", fsub_c_sig)

  glue("extern void {fsub@name}({str_flatten_commas(fsub_c_sig)});")
}

# # ' @export
# `@.default` <- function(x, name) {
#   if (isS4(x))
#     methods::slot(x, name)
#   else
#     attr(x, name, TRUE)
# }
#
# # ' @export
# `@<-.default` <- function(x, name, value) {
#   if (isS4(x))
#     methods::`slot<-`(x, name, value = value)
#   else
#     `attr<-`(x, name, value)
# }
#
# # ' @importFrom utils .AtNames findMatches
# .AtNames.default <- function(x, pattern = "") {
#   if (isS4(x))
#     findMatches(pattern, methods::slotNames(x))
#   else
#     findMatches(pattern, names(attributes(x)))
# }
#
# on_load_register_.AtNames.default <- function() {
#   # if we register via NAMESPACE, we get warning
#   # about overwriting utils:::.AtNmaes.default
#   registerS3method(".AtNames", "default", .AtNames.default)
# }

.onLoad <- function(...) {
  S7::methods_register()
  asNamespace("dotty")$dotify()
  # on_load_register_.AtNames.default()
}

new_fortran_subroutine <- function(name, closure, parent = emptyenv()) {

  check_all_var_names_valid(closure)

  # translate body, and populate scope with variables
  body <- body(closure)

  # defuse calls like `-1` and `1+1i`. Not really necessary, but simplifies downstream a little.
  body <- defuse_numeric_literals(body)

  # TODO: try harder here to use one of the input vars as the output var
  body <- ensure_last_expr_sym(body)

  # update closure with sym return value
  base::body(closure) <- body
  # body <- rlang::zap_srcref(body)

  scope <- new_scope(closure, parent)

  # inject symbols for var sizes in declare calls, so like:
  #   declare(type(foo = integer(nr, NA)),
  #           type(bar = integer(nr, 3)))
  # become:
  #   declare(type(foo = integer(foo_dim_1_, foo_dim_2_)),
  #           type(bar = integer(foo_dim_1_, 3L)))
  body <- substitute_declared_sizes(body)
  body <- r2f(drop_last(body), scope)

  # check all input vars were declared
  # TODO: this check might be too late, because r2f() might throw cryptic errors
  # when handling undeclared variables. Either throw better errors from r2f(), or
  # handle all declares first
  for(arg_name in names(formals(closure))) {
    if (is.null(var <- get0(arg_name, scope)))
      stop("arg not declared: ", arg_name)
  }

  # figure out the return variable.
  if (is.symbol(last_expr <- last(body(closure)))) {
    return_var <- get(last_expr, scope)
    return_var@is_return <- TRUE
    scope[[as.character(last_expr)]] <- return_var
  } else {
    # lots we can still do here, just not implemented yet.
    stop("last expression in the function must be a bare symbol")
  }

  manifest <- r2f.scope(scope)
  fsub_arg_names <- attr(manifest, "signature", TRUE)

  used_iso_bindings <- unique(unlist(use.names = FALSE, list(
    lapply(scope, function(var) {
      list(
        switch(
          var@mode,
          double = "c_double",
          integer = "c_int",
          logical = if (var@name %in% fsub_arg_names)
            "c_int",
          complex = "c_double_complex",
          raw = "c_int8_t"
        ),
        lapply(var@dims, function(size) {
          syms <- all.vars(size)
          c(if (any(grepl("__len_$", syms))) "c_ptrdiff_t",
            if (any(grepl("__dim_[0-9]+_$", syms))) "c_int")
        })
      )
    }))))

  # check for literal kinds
  if (!"c_int" %in% used_iso_bindings) {
    if (grepl("\\b[0-9]+_c_int\\b", body))
      append(used_iso_bindings) <- "c_int"
  }
  if (!"c_double" %in% used_iso_bindings) {
    if (grepl("\\b[0-9]+\\.[0-9]+_c_double\\b", body))
      append(used_iso_bindings) <- "c_double"
  }
  used_iso_bindings <- sort(used_iso_bindings, method = "radix")

  subroutine <- glue("
    subroutine {name}({str_flatten_commas(fsub_arg_names)}) bind(c)
      use iso_c_binding, only: {str_flatten_commas(used_iso_bindings)}
      implicit none

    {indent(manifest)}

    {indent(body)}
    end subroutine
    ")

  subroutine <- insert_fortran_line_continuations(subroutine)

  FortranSubroutine(
    subroutine,
    name = name,
    signature = fsub_arg_names,
    scope = scope,
    closure = closure
  )
}

insert_fortran_line_continuations <- function(code, preserve_attributes = TRUE) {
  attrs_in <- attributes(code)

  code <- as.character(code)
  lines <- str_split_lines(code)
  lines <- trimws(lines, "right")

  if (any(too_long <- nchar(lines) > 132)) {
    # remove leading indentation
    lines[too_long] <- trimws(lines[too_long], "left")

    # move trailing comment at the end
    lines[too_long] <- sub("^(.*)!(.*)$", "!\\2\n\\1", lines[too_long])
    lines <- str_split_lines(lines)

    # maximum 255 continuations are allowed
    for (i in 1:256) {
      if (!any(too_long <- nchar(lines) > 132))
        break
      lines[too_long] <- sub("^(.{1,130})\\s", "\\1 &\n", lines[too_long])
      lines <- str_split_lines(lines)
    }
    if (i > 255L)
      stop("Too long line encountered. Please split long expressions into a sequence of smaller expressions.")
  }

  code <- str_flatten_lines(lines)
  if (preserve_attributes)
    attributes(code) <- attrs_in
  code
}

defuse_numeric_literals <- function(e) {
  if (is.call(e)) {
    e <- as.call(lapply(e, defuse_numeric_literals))
    if (is.symbol(e1 <- e[[1L]]) &&
        as.character(e1) %in% c("+", "-", "*", "/", "%%", "%/%", "^") &&
        all(map_lgl(e[-1L], is.atomic))) {
      e <- eval(e, baseenv())
    }
  }
  e
}

ensure_last_expr_sym <- function(bdy) {
  if (!is_call(bdy, quote(`{`)))
    stop("bad body, needs {")
  if (!is.symbol(last_expr <- last(bdy))) {
    bdy[[length(bdy)]] <- call("<-", quote(out_), last_expr)
    bdy[[length(bdy) + 1L]] <- quote(out_)
  }
  bdy
}

whole_doubles_to_ints <- function(x) {
  walker <- function(x) {
    switch(
      typeof(x),
      double = if (trunc(x) == x) as.integer(x),
      language =  as.call(lapply(x, walker)),
      list = lapply(x, walker),
      x
    )
  }
  walker(x)
}

function(closure, parent = emptyenv()) {}

This code segment functions to: Create a managed execution context with ordered variable tracking, automatic temporary identifier generation, and type-constrained assignment validation for symbolic objects.

```r
[TASK_BEGIN]
new_scope <- function(closure, parent = emptyenv()) {
  env <- new_ordered_env(parent = parent)
  attr(env, "closure") <- closure
  class(env) <- c("quickr_scope", class(env))
  env
}
[TASK_END]
```