.packageName <- "rdyncall"

new.callback <- function(signature, fun, envir=new.env())
{
  stopifnot( is.function(fun) )
  stopifnot( is.character(signature) )
  cb <- .Call("new_callback", signature, fun, envir, PACKAGE="rdyncall")
  
  attr(cb,"signature") <- signature
  attr(cb,"envir") <- envir
  attr(cb,"fun") <- fun
  reg.finalizer(cb, function(x) { .Call("free_callback", x, PACKAGE="rdyncall") } )
  return(cb)
}
# R-Package: rdyncall
# File: rdyncall/R/dynbind.R
# Description: single-entry front-end to dynamic binding of library functions 

dynbind <- function(libname, libsig, envir=parent.frame(), callmode="cdecl", pat=NULL, replace=NULL, funcptr=FALSE)
{
  # load shared library
  libh <- dynfind(libname)
  if ( is.null(libh) )
    stop("unable to find '", libname,"'")
  
  # -- convert library signature to signature table
  
  # eat white spaces
  sigtab <- gsub("[ \n\t]*","",libsig)  
  # split functions at ';'
  sigtab <- strsplit(sigtab, ";")[[1]]  
  # split name/call signature at '('
  sigtab <- strsplit(sigtab, "\\(")
  
  # -- install functions
 
  # make function call symbol
  dyncallfunc <- as.symbol( paste(".dyncall.",callmode, sep="") )  
  # report info
  syms.failed <- character(0)

  for (i in seq(along=sigtab)) 
  {
    symname   <- sigtab[[i]][[1]]    
    rname  <- if (!is.null(pat)) sub(pat, replace, symname) else symname
    signature <- sigtab[[i]][[2]]
    # lookup symbol
    address  <- .dynsym( libh, symname )
    
    if (!is.null(address))
    {
      # make call function f
      f <- function(...) NULL
      if (funcptr)
      {
        body(f) <- substitute( dyncallfunc( .unpack1(address,0,"p"), signature,...), list(dyncallfunc=dyncallfunc,address=address,signature=signature) )
      }
      else
      {
        body(f) <- substitute( dyncallfunc(address, signature,...), list(dyncallfunc=dyncallfunc,address=address,signature=signature) )
      }
      environment(f) <- envir # NEW
      # install symbol
      assign( rname, f, envir=envir)  
    }
    else
    {
      syms.failed <- c(syms.failed,symname)
    }
  }
  # return dynbind.report
  x <- list(libhandle=libh, syms.failed=syms.failed)
  class(x) <- "dynbind.report"
  return(x)
}
# File: rdyncall/R/dyncall.R
# Description: dyncall bindings for R

# ----------------------------------------------------------------------------
# available call modes

.callmodes <- c("cdecl","stdcall","fastcall.gcc","fastcall.msvc","this.gcc","this.msvc")

# ----------------------------------------------------------------------------
# call vm alloc/free

new.callvm <- function( callmode = c("cdecl","stdcall"), size = 4096L )
{
  callmode <- match.arg(callmode)
  x <- .Call("new_callvm", callmode, size, PACKAGE="rdyncall")
  reg.finalizer(x, free.callvm)
  return(x)
}

free.callvm <- function(x)
{
  .Call("free_callvm", x, PACKAGE="rdyncall")
}

# ----------------------------------------------------------------------------
# calling convention: cdecl 

# callvm.cdecl   <- new.callvm("cdecl")


.dyncall.cdecl <- function( address, signature, ... )
{
  .External("dyncall", callvm.cdecl, address, signature, ..., PACKAGE="rdyncall")
}

# ----------------------------------------------------------------------------
# calling convention: stdcall on win32 / otherwise fallback to cdecl

if (.Platform$OS == "windows") {  
#  callvm.stdcall <- new.callvm("stdcall")
} else {
#  callvm.stdcall <- .callvm.cdecl
}

.dyncall.stdcall <- function( address, signature, ... )
{
  .External("dyncall", callvm.stdcall, address, signature, ..., PACKAGE="rdyncall")
}  

# ----------------------------------------------------------------------------
# generic call

.dyncall <- function( address, signature, ... , callmode = "cdecl" )
{
  callvm <- switch(callmode, cdecl=callvm.cdecl, stdcall=callvm.stdcall)
  .External("dyncall", callvm, address, signature, ..., PACKAGE="rdyncall")
}

callvm.cdecl <- NULL
callvm.stdcall <- NULL

.onLoad <- function(libname,pkgname)
{
  callvm.cdecl <<- new.callvm("cdecl")
  callvm.stdcall <<- new.callvm("stdcall")
}
# R-Package: rdyncall
# File: rdyncall/R/dynfind.R
# Description: locating system libraries in common places  

# ----------------------------------------------------------------------------
# function: pathsFromEnv
# description: get paths character vector from environment variable such as LD_LIBRARY_PATH.
pathsFromEnv <- function(name)
  unlist( strsplit( unname( Sys.getenv(name) ), .Platform$path.sep ) )


.libLocations <- c("/lib","/usr/lib", "/usr/local/lib", "/opt/local/lib")

if (Sys.info()[["sysname"]] == "Darwin")
{
  .libLocations <- c(.libLocations, "/Library/Frameworks/R.framework/Resources/lib/" )
}

.sysname <- Sys.info()[["sysname"]]

try.framework.locations <- c("/Library/Frameworks","/System/Library/Frameworks")
dynfind.darwin.framework <- function(frameworks, auto.unload=TRUE)
{
  try.frameworks <- frameworks
  for (location in try.framework.locations) {
    for (framework in try.frameworks) {
      path <- paste( location, "/", framework, ".framework/", framework, sep="")    
      x <- .dynload(path, auto.unload)
      if (!is.null(x)) return(x)
    }
  }
  return(NULL)
}

dynfind <- function(libnames, auto.unload=TRUE)
{
  if ( .sysname == "Windows" ) {    
    try.locations <- pathsFromEnv("PATH")
    filesep <- "\\"
  } else { # unix
    try.locations <- c("/lib","/usr/lib","/usr/local/lib","/opt/local/lib", pathsFromEnv("LD_LIBRARY_PATH") )
    filesep <- "/"
  }
  try.prefixes <- c("","lib")
  try.suffixes <- c("",.Platform$dynlib.ext)  
  try.names <- libnames
  if ( .sysname == "Darwin" ) {
    try.locations <- c(try.locations, "/Library/Frameworks/R.framework/Resources/lib/")
    handle <-dynfind.darwin.framework(libnames, auto.unload=auto.unload)
    if( !is.null(handle) ) return(handle)
    try.suffixes <- c(".dylib",try.suffixes)
  }

  # remove "" entries and duplicates
  try.locations <- unique( try.locations[try.locations != ""] )
  
  # put '""' at the very end
  # try.locations <- c(try.locations,"")
  
  for (location in try.locations)
  {
    for (prefix in try.prefixes)
    {
      for(suffix in try.suffixes)
      {
        for(libname in try.names) 
        {
          path <- paste( location, filesep, prefix, libname, suffix, sep="" )
          x <- .dynload(path, auto.unload=auto.unload)
          if (!is.null(x)) return(x)
        }
      }
    }
  }
  # try directly
  for(libname in try.names) 
  {
    .dynload(libname, auto.unload=auto.unload)
  }  
}

#.dynpath <- function(add = NULL, remove = NULL)
#{
#  if (nargs() == 0)
#  {
#    strsplit( Sys.getenv("path"), .Platform$path.sep)[[1]]
#  }
#  else
#  {
#    if (! missing(add))
#    {
#      paste(Sys.getenv("path"), paste(add,collapse=.Platform$path.sep), sep=.Platform$path.sep)
#    }
#    if (! missing(remove))
#    {
#      .NotYetImplemented()
#    }
#  }
#}
# File: rdyncall/R/dyncall.R
# Description: R bindings for dynload library
#

.dynload <- function(libpath, auto.unload=TRUE)
{  
  libh <- .Call("dynload", as.character(libpath), PACKAGE="rdyncall")
  if (!is.null(libh)) {
    attr(libh, "path") <- libpath
    attr(libh, "auto.unload") <- auto.unload
    if (auto.unload) reg.finalizer(libh, .dynunload)
  }
  libh
}

.dynunload <- function(libh)
{
  if (!is.externalptr(libh)) stop("libh argument must be of type 'externalptr'")
  .Call("dynunload", libh, PACKAGE="rdyncall")
}

.dynsym <- function(libh, name, protect.lib=TRUE)
{
  if (!is.externalptr(libh)) stop("libh argument must be of type 'externalptr'") 
  .Call("dynsym", libh, as.character(name), as.logical(protect.lib), PACKAGE="rdyncall")
}

# File: rdyncall/R/dynports.R
# Description: repository for multi-platform bindings to binary components.

# the following code is copied from 'loadNamespace':
makeNamespace <- function(name, version = NULL, lib = NULL) {
  impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE)
  attr(impenv, "name") <- paste("imports", name, sep = ":")
  env <- new.env(parent = impenv, hash = TRUE)
  name <- as.character(as.name(name))
  version <- as.character(version)
  info <- new.env(hash = TRUE, parent = baseenv())
  assign(".__NAMESPACE__.", info, envir = env)
  assign("spec", c(name = name, version = version), 
      envir = info)
  setNamespaceInfo(env, "exports", new.env(hash = TRUE, 
          parent = baseenv()))
  setNamespaceInfo(env, "imports", list(base = TRUE))
  setNamespaceInfo(env, "path", file.path(lib, name))
  setNamespaceInfo(env, "dynlibs", NULL)
  setNamespaceInfo(env, "S3methods", matrix(NA_character_, 
          0L, 3L))
  assign(".__S3MethodsTable__.", new.env(hash = TRUE, 
          parent = baseenv()), envir = env)
  .Internal(registerNamespace(name, env))
  env
}

# deprecated package-based container:
loadDynportPackage  <- function(portname, filename, envir=NULL, do.attach=TRUE)
{
  # setup dynport environment search name  
  envname <- paste("package",portname,sep=":")            
  # check if dynport already loaded  
  if ( envname %in% search() ) return()
  if (missing(envir))
  {
    envir <- new.env(parent=baseenv())
    attr(envir, "name") <- envname
  }
  # process portfile
  sys.source(portfile, envir=envir) 
  if (do.attach)
    attach(envir)
}

# new namespace-based container:
loadDynportNamespace <- function(name, portfile, do.attach=TRUE)
{ 
  # check if dynport namespace already loaded  
  if ( name %in% loadedNamespaces() ) return()
  # create namespace  
  env <- makeNamespace(name)
  # process portfile
  sys.source(portfile, envir=env)  
  # export all objects, expect '.' variables reserved for internal use
  namespaceExport(env, ls(env))
  # attach namespace
  if (do.attach) attachNamespace(env)
}

# Front-end:

dynport <- function(portname, filename=NULL, repo=system.file("dynports", package="rdyncall"))
{
  # literate portname string
  portname <- as.character(substitute(portname))
  if (missing(filename))
  {
    # search for filename
    filename <- file.path( repo, paste(portname,".R",sep="") )
    if ( !file.exists(filename) ) filename <- file.path( repo, paste(portname,".json",sep="") )        
    if ( !file.exists(filename) ) stop("dynport '", portname, "' not found.")    
  }
  loadDynportNamespace(portname, filename)  
}

dynport.unload <- function(portname)
{
  unloadNamespace(portname)
}

#dynport.unload <- function(portname)
#{
#  portname <- as.character(substitute(portname))
#  envname <- paste("dynport",portname,sep=":")
#  detach( name=envname )
#}

#dynport.require <- function(portname)
#{
#  
#}


future.json.format <- function() 
{
  
  require(rjson)
  
  jsonparser <- newJSONParser()
  
  parseJSON <- function(path)
  {
    parser <- newJSONParser()
    f <- file(path)
    open(f)
    while(TRUE) 
    {
      aLine <- readLines(f, 1)
      if (length(aLine) == 0) break    
      parser$addData( aLine )
    }
    close(f)
    parser$getObject()
  }
  
  from.json <- function(file)
  {
    json <- parseJSON(file)
    sysname <- Sys.info()[["sysname"]][[1]]
    paste( "_OS_", toupper(sysname) )   
    libname <- json$libname
    dynbind(libname, libsignature, envir=parent.frame(), callmode="cdecl")
  }
  
  dynport.json <- function(portname, envir=NULL, pos = 2, auto.attach=TRUE)
  {
    
  }
  
}
# ----------------------------------------------------------------------------
# dynport basetype sizes

.basetypeSizes <- c(
    B=.Machine$sizeof.long,
    c=1L,
    C=1L,
    s=2L,
    S=2L,
    i=.Machine$sizeof.long,
    I=.Machine$sizeof.long,
    j=.Machine$sizeof.long,
    J=.Machine$sizeof.long,
    l=.Machine$sizeof.longlong,
    L=.Machine$sizeof.longlong,
    f=4L,
    d=8L,
    p=.Machine$sizeof.pointer,
    x=.Machine$sizeof.pointer,
    Z=.Machine$sizeof.pointer,
    v=0L
)

# ----------------------------------------------------------------------------
# dynport type information
#

TypeInfo <- function(...) 
{
  x <- list(...)
  class(x) <- "typeinfo"
  return(x)
}

getTypeInfo <- function(typeName, envir=parent.frame())
{
  char1 <- substr(typeName, 1, 1)
  switch(char1,
    "*"=TypeInfo(type="pointer", size=.Machine$sizeof.pointer, align=.Machine$sizeof.pointer, basetype=substr(typeName,2,nchar(typeName)), signature=typeName),
    "<"={ 
      x <- getTypeInfo(substr(typeName, 2,nchar(typeName)-1), envir=envir) 
      if (!is.null(x)) 
        return(x) 
      else 
        return(TypeInfo(type="struct"))
    },
    {
      # try as basetype
      basetypeSize <- unname(.basetypeSizes[typeName])
      if ( !is.na(basetypeSize) ) return(TypeInfo(type="base", size=basetypeSize, align=basetypeSize, signature=typeName))
      # try lookup symbol
      else if (exists(typeName,envir=envir) ) {
        info <- get(typeName,envir=envir)
        if (!inherits(info, "typeinfo")) stop("not a type information symbol")
        return(info)
      }
      # otherwise fail
      else NULL
      # else stop("unknown type info: ",typeName)
    }
  )
}

# ----------------------------------------------------------------------------
# align C offsets

align <- function(offset, alignment)
{
  as.integer( as.integer( (offset + alignment-1L) / alignment ) * alignment )
}

# ----------------------------------------------------------------------------
# field information (structures and unions)

makeFieldInfo <- function(fieldNames, types, offsets)
{  
  data.frame(type=I(types), offset=offsets, row.names=fieldNames)  
}

# ----------------------------------------------------------------------------
# parse structure signature

makeStructInfo <- function(structSignature, fieldNames, envir=parent.frame())
{
  # computations:
  types    <- character()
  offsets  <- integer()
  offset   <- 0L
  maxAlign <- 1L
  # scan variables:
  n        <- nchar(structSignature)
  i        <- 1L
  start    <- i
  while(i <= n)
  {
    char  <- substr(structSignature,i,i)
    if (char == "*") { 
      i <- i + 1L ; next
    } else if (char == "<") {
      i <- i + 1L
      while (i < n) {
        if ( substr(structSignature,i,i) == ">" ) break
        i <- i + 1L
      }    
    } 
    typeName  <- substr(structSignature, start, i)
    types     <- c(types, typeName)
    typeInfo  <- getTypeInfo(typeName, envir=envir)
    alignment <- typeInfo$align
    maxAlign  <- max(maxAlign, alignment)
    offset    <- align( offset, alignment )
    offsets   <- c(offsets, offset)
    
    # increment offset by size
    offset    <- offset + typeInfo$size

    # next token
    i         <- i + 1L
    start     <- i
  } 
  # align the structure size (compiler-specific?)
  size    <- align(offset, maxAlign)
  # build field information
  fields  <- makeFieldInfo(fieldNames, types, offsets)
  TypeInfo(type="struct",size=size,align=maxAlign,fields=fields)
}

parseStructInfos <- function(sigs, envir=parent.frame())
{
  # split functions at ';'
  sigs <- unlist( strsplit(sigs, ";") )  
  # split name/struct signature at '('
  sigs <- strsplit(sigs, "[{]")
  infos <- list()
  for (i in seq(along=sigs)) 
  {
    n <- length(sigs[[i]])
    if ( n == 2 ) {
      # parse structure name
      name     <- sigs[[i]][[1]]
      name     <- gsub("[ \n\t]*","",name)
      # split struct signature and field names
      tail     <- unlist( strsplit(sigs[[i]][[2]], "[}]") )
      sig      <- tail[[1]]
      if (length(tail) == 2)
        fields   <- unlist( strsplit( tail[[2]], "[ \n\t]+" ) ) 
      else 
        fields   <- NULL
      assign(name, makeStructInfo(sig, fields, envir=envir), envir=envir)
    }
  }  
}

# ----------------------------------------------------------------------------
# parse union signature

makeUnionInfo <- function(unionSignature, fieldNames, envir=parent.frame())
{
  # computations:
  types    <- character()
  maxSize  <- 0L
  maxAlign <- 1L 
  # scan variables:
  i       <- 1L
  start   <- i
  n       <- nchar(unionSignature)
  while(i <= n) {
    char  <- substr(unionSignature,i,i)
    if (char == "*") {
      i <- i + 1L ; next
    } else if (char == "<") {
      i <- i + 1L
      while (i < n) {
        if ( substr(unionSignature,i,i) == ">" ) break
        i <- i + 1L
      }
    } 
    typeName <- substr(unionSignature,start,i)
    types    <- c(types, typeName)
    typeInfo <- getTypeInfo(typeName, envir)
    maxSize  <- max( maxSize, typeInfo$size )
    maxAlign <- max( maxAlign, typeInfo$align )
    # next token
    i        <- i + 1L
    start    <- i
  }
  offsets <- rep(0L, length(types) )
  fields  <- makeFieldInfo(fieldNames, types, offsets)  
  TypeInfo(type="union", fields=fields, size=maxSize, align=maxAlign)
}

parseUnionInfos <- function(sigs, envir=parent.frame())
{
  # split functions at ';'
  sigs <- unlist( strsplit(sigs, ";") )  
  # split name/union signature at '|'
  sigs <- strsplit(sigs, "[|]")
  infos <- list()
  for (i in seq(along=sigs)) 
  {
    n <- length(sigs[[i]])
    if ( n == 2 ) {
      # parse union name
      name     <- sigs[[i]][[1]]
      name     <- gsub("[ \n\t]*","",name)
      # split union signature and field names
      tail     <- unlist( strsplit(sigs[[i]][[2]], "[}]") )
      sig      <- tail[[1]]
      if (length(tail) == 2)
        fields   <- unlist( strsplit( tail[[2]], "[ \n\t]+" ) ) 
      else 
        fields   <- NULL
      assign( name, makeUnionInfo(sig, fields, envir=envir), envir=envir )
    }
  }  
}


# ----------------------------------------------------------------------------
# raw backed struct's (S3 Class)

as.struct <- function(x, structName)
{
  attr(x, "struct") <- structName
  class(x) <- "struct"
  return(x)
}

new.struct <- function(structName)
{
  info <- getTypeInfo(structName)
  if (! info$type %in% c("struct","union") ) stop("no structure type")
  x <- raw( info$size )
  attr(x, "struct") <- structName
  class(x) <- "struct"
  return(x)
}

"$.struct" <- 
unpack.struct <- function(x, index)
{
  structName <- attr(x, "struct")
  structInfo <- getTypeInfo(structName)
  fieldInfos <- structInfo$fields
  offset <- fieldInfos[index,"offset"]
  if (is.na(offset)) stop("unknown field index '", index ,"'")
  fieldTypeName   <- as.character(fieldInfos[[index,"type"]])
  fieldTypeInfo   <- getTypeInfo(fieldTypeName)
  if (fieldTypeInfo$type %in% c("base","pointer")) {
    .unpack1(x, offset, fieldTypeInfo$signature)
  } else if ( !is.null(fieldTypeInfo$fields) ) {
    if (is.raw(x)) {
      size <- fieldTypeInfo$size
      as.struct( x[(offset+1):(offset+1+size-1)], structName=fieldTypeName)
    } else if (is.externalptr(x)) {
      as.struct( offsetPtr(x, offset), structName=fieldTypeName) 
    }
  } else {
    stop("invalid field type '", fieldTypeName,"' at field '", index )
  }
}

"$<-.struct" <- 
pack.struct <- function( x, index, value )
{
  structName   <- attr(x, "struct")
  structInfo   <- getTypeInfo(structName)
  fieldInfos   <- structInfo$fields
  offset <- fieldInfos[index,"offset"]
  if (is.na(offset)) stop("unknown field index '", index ,"'")
  fieldTypeName <- as.character(fieldInfos[index,"type"])
  fieldTypeInfo <- getTypeInfo(fieldTypeName)
  if (fieldTypeInfo$type == "base") {
    .pack1( x, offset, fieldTypeInfo$signature, value )
  }
  else if ( !is.null(fieldTypeInfo$fields) ) {
    size <- fieldTypeInfo$size
    x[(offset+1):(offset+1+size-1)] <- as.raw(value)
  }
  else {
    stop("invalid field type '", fieldTypeName,"' at field '", index )
  }
  return(x)
}

print.struct <- function(x, indent=0)
{
  structName <- attr(x, "struct")
  structInfo <- getTypeInfo(structName)
  fieldInfos <- structInfo$fields
  fieldNames <- rownames(fieldInfos)
  # print data without last
  cat( "struct ", structName, " {\n")
  for (i in seq(along=fieldNames)) 
  { 
    cat( rep("  ", indent+1), fieldNames[[i]] , ":" )
    val <- unpack.struct(x, fieldNames[[i]])
    if (typeof(val) == "externalptr") val <- .addrval(val)        
    if (class(val) == "struct") { print.struct(val, indent=indent+1) }
    else cat( val, "\n" )
  }
  cat( rep("  ", indent), "}\n")
}

# utilities to search for shared libraries in the system

# ----------------------------------------------------------------------------
# global: .sysLibPath
# description: contains a list of common paths
.sysLibPaths <- if (.Platform$OS == "windows") { # windows
  # TODO: windows
} else { # unix
	local({
		commons <- c("/usr/local/lib", "/usr/lib", "/lib")
		paths <- c(commons, pathsFromEnv("LD_LIBRARY_PATH") )
    if ( Sys.info()[["sysname"]] == "Darwin" ) {
      # TODO: darwin
      paths <- c(paths, pathsFromEnv("DYLD_LIBRARY_PATH") )    
    }
    paths <- unique(paths)
    paths[ paths != "" ]	
	})
}

# ----------------------------------------------------------------------------
# function: findLibPath
# search shared library in common places (all platforms)

findLibPath <- function(name, paths=.sysLibPaths)
{
	for(i in paths) {
		path <- file.path(i, paste("lib", name,.Platform$dynlib.ext,sep="") )    
		if ( file.exists(path) ) return(path)
	}
	NA
}

# ----------------------------------------------------------------------------
# function: findFrameworkPath
# search shared library in frameworks for darwin

.sysFrameworkPaths <- c("/Library/Frameworks", "/System/Library/Frameworks")

findFrameworkLibPath <- function(name, paths=.sysFrameworkPaths)
{
  # TODO: darwin    
  for (i in paths) {
    path <- file.path( i, paste(name, ".framework", sep=""), name)
    if (file.exists(path)) return(path)
  }
  NA
}

# ----------------------------------------------------------------------------
# generic extension component search (currently shared libraries supported)

findComponentPath <- function(name)
{
  if (Sys.info()[["sysname"]] == "Darwin") {
    x <- findFrameworkLibPath()
    if (!is.na(x)) return(x)
  }
  findLibPath(name)
}
# File: rdyncall/R/pack.R
# Description: (un-)packing functions for raw C struct data. 

.pack1   <- function(x, offset, signature, value)
{
  char1 <- substr(signature,1,1)
  if (char1 == "*") char1 <- "p"
  .Call("pack1", x, as.integer(offset), char1, value, PACKAGE="rdyncall" )
}

.unpack1 <- function(x, offset, signature)
{
  sigchar <- char1 <- substr(signature,1,1)
  if (char1 == "*") sigchar <- "p"
  x <- .Call("unpack1", x, as.integer(offset), sigchar, PACKAGE="rdyncall" )
  if (char1 == "*")
  {
    attr(x,"basetype") <- substr(signature,2,nchar(signature))
  }
  return(x)
}

# File: rdyncall/R/struct.R
# Description: handling of aggregate low-level structures

old <- function()
{

.sigsizes <- c(
B=.Machine$sizeof.long,
c=1L,
C=1L,
s=2L,
S=2L,
i=.Machine$sizeof.long,
I=.Machine$sizeof.long,
j=.Machine$sizeof.long,
J=.Machine$sizeof.long,
l=.Machine$sizeof.longlong,
L=.Machine$sizeof.longlong,
f=4L,
d=8L,
p=.Machine$sizeof.pointer,
x=.Machine$sizeof.pointer,
Z=.Machine$sizeof.pointer,
v=0L
)

typemap.C <- c(
UINT='i',
WNDPROC='p',
int='i',
HINSTANCE='p',
HICON='p',
HCURSOR='p',
HBRUSH='p',
LPCTSTR='Z',
LPCTSTR='Z',
void='v'
)

structinfo <- function( x , ... ) UseMethod("structinfo")

structinfo.struct    <- function(struct) attr( struct, "structinfo" )
structinfo.character <- function(string, typemap=typemap.C, sizemap=.sigsizes) {
  
  # split at whitespace and ';'
  
  tab <- strsplit(string,'[; \t\n]+')[[1]]
  if (tab[1] == "") tab <- tab[-1]
  n <- length(tab)
  even <- seq(1,n,by=2)
  odd  <- seq(2,n,by=2)
  types   <- tab[even]
  ids     <- tab[odd]
  types   <- typemap[types]
  sizes   <- sizemap[types]   
  offsets <- c(0,cumsum(sizes))
  ids     <- c(ids,".end")
  types   <- c(types, "v" )
  sizes   <- c(sizes, 0 )
  x <- data.frame(id=ids,type=types,size=sizes,offset=offsets,row.names=1)
  class(x) <- c("structinfo", class(x) )
  return(x)
  # signature = paste( x, collapse="" )
}

# ----------------------------------------------------------------------------
# sizeof operator in R for structs, unions and multi-precision integers 

sizeof <- function(x) UseMethod("sizeof")

sizeof.structinfo <- function(structinfo) structinfo[[".end","offset"]]
sizeof.struct     <- function(struct) { sizeof(structinfo(struct)) }

new.struct <- function(structinfo)
{
  stopifnot(inherits(structinfo, "structinfo") )
  x <- raw( sizeof(structinfo) )
  class(x) <- "struct"
  attr(x,"structinfo") <- structinfo
  return(x)
}

as.structptr <- function(structinfo, x)
{
  stopifnot(inherits(structinfo, "structinfo") )
  class(x) <- c("struct", class(x) )
  attr(x,"structinfo") <- structinfo
  return(x)
}


"$<-.struct" <- 
pack.struct <- function( x, index, value )
{
  info <- attr(x, "struct")
  .pack1( x, info[[index,"offset"]], as.character(info[index,"type"]), value )
  return(x)
}

"$.struct" <- 
unpack.struct <- function(x, index)
{
  info <- attr(x, "struct")
  .unpack1(x, info[[index,"offset"]], as.character(info[index,"type"]) )  
}

"str.struct" <- function(x)
{
  info <- structinfo(x)
  name <- rownames(info)
  # print data without last
  cat("struct {\n")
  for (i in 1:(nrow(info)-1)) 
  {
    val <- unpack.struct(x,i)
    if (typeof(val) == "externalptr") val <- .addrval(val)
    cat( name[[i]] , " ", val, "\n" )
  }
  cat("}\n")
}

}
.dataptr <- function(x, offset=0L)
{
  .Call("dataptr", x, as.integer(offset), PACKAGE="rdyncall" )
}

.addrval <- function(x)
{
  .Call("addrval", x, PACKAGE="rdyncall")
}

is.externalptr <- function(x)
{
  (typeof(x) == "externalptr")
}

as.externalptr <- function(x)
{
  if (is.atomic(x))
  {
    value <- as.integer(x)
    return(.unpack1(value, 0, 'p'))
  }
  else if (is.function(x))
  {
    # extract dynbind function pointers
    code <- body(x)
    if ( as.character(code[[1]]) == ".dyncall.cdecl" ) return(code[[2]])    
    else if ( as.character(code[[1]]) == ".dyncall.stdcall" ) return(code[[2]])    
  }
  stop("invalid type")
}

is.nullptr <- function(x)
{
  stopifnot(is.externalptr(x))
  (.addrval(x) == 0)    
}

makeExternalPtr <- function(x,y,z)
{
  .Call("makeExternalPtr", PACKAGE="rdyncall")
}

offsetPtr <- function(x, offset)
{
  .Call("offsetPtr", x, offset, PACKAGE="rdyncall")
}

