Nothing
# Package: rdyncall
# File: R/dynstruct.R
# Description: Handling of aggregate (struct/union) C types
# ----------------------------------------------------------------------------
# dynport basetype sizes
.basetypeSizes <- c(
B=.Machine$sizeof.long,
c=1,
C=1,
s=2,
S=2,
i=4,
I=4,
j=.Machine$sizeof.long,
J=.Machine$sizeof.long,
l=.Machine$sizeof.longlong,
L=.Machine$sizeof.longlong,
f=4,
d=8,
p=.Machine$sizeof.pointer,
x=.Machine$sizeof.pointer,
Z=.Machine$sizeof.pointer,
v=0
)
# ----------------------------------------------------------------------------
# dynport type information
#
TypeInfo <- function(name, type = c("base","pointer","struct","union"), size = NA, align = NA, basetype = NA, fields = NA, signature = NA)
{
type <- match.arg(type)
x <- list(name = name, type = type, size = size, align = align, basetype = basetype, fields = fields, signature = signature)
class(x) <- "typeinfo"
return(x)
}
is.TypeInfo <- function(x)
{
inherits(x, "typeinfo")
}
getTypeInfo <- function(name, envir=parent.frame())
{
if (is.character(name)) {
getTypeInfoByName(name, envir)
} else if (is.TypeInfo(name)) {
name
} else {
stop("unknown type")
}
}
getTypeInfoByName <- function(typeName, envir=parent.frame())
{
char1 <- substr(typeName, 1, 1)
switch(char1,
"*"=TypeInfo(name=typeName, 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(name=typeName, type="struct"))
},
{
# try as basetype
basetypeSize <- unname(.basetypeSizes[typeName])
if ( !is.na(basetypeSize) ) return(TypeInfo(name=typeName,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-1) / 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(name, signature, fieldNames, envir=parent.frame())
{
# computations:
types <- character()
offsets <- integer()
offset <- 0
maxAlign <- 1
# scan variables:
n <- nchar(signature)
i <- 1
start <- i
while(i <= n)
{
char <- substr(signature,i,i)
if (char == "*") {
i <- i + 1 ; next
} else if (char == "<") {
i <- i + 1
while (i < n) {
if ( substr(signature,i,i) == ">" ) break
i <- i + 1
}
}
typeName <- substr(signature, 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 + 1
start <- i
}
# align the structure size (compiler-specific?)
size <- align(offset, maxAlign)
# build field information
fields <- makeFieldInfo(fieldNames, types, offsets)
TypeInfo(name=name,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(name, sig, fields, envir=envir), envir=envir)
}
}
}
# ----------------------------------------------------------------------------
# parse union signature
makeUnionInfo <- function(name, signature, fieldNames, envir=parent.frame())
{
# computations:
types <- character()
maxSize <- 0
maxAlign <- 1
# scan variables:
i <- 1
start <- i
n <- nchar(signature)
while(i <= n) {
char <- substr(signature,i,i)
if (char == "*") {
i <- i + 1 ; next
} else if (char == "<") {
i <- i + 1
while (i < n) {
if ( substr(signature,i,i) == ">" ) break
i <- i + 1
}
}
typeName <- substr(signature,start,i)
types <- c(types, typeName)
typeInfo <- getTypeInfo(typeName, envir)
maxSize <- max( maxSize, typeInfo$size )
maxAlign <- max( maxAlign, typeInfo$align )
# next token
i <- i + 1
start <- i
}
offsets <- rep(0, length(types) )
fields <- makeFieldInfo(fieldNames, types, offsets)
TypeInfo(name=name, 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(name, sig, fields, envir=envir), envir=envir )
}
}
}
# ----------------------------------------------------------------------------
# raw backed struct's (S3 Class)
as.struct <- function(x, type)
{
if (is.TypeInfo(x)) structName <- type$name
attr(x, "struct") <- type
class(x) <- "struct"
return(x)
}
new.struct <- function(type)
{
if (is.character(type)) {
name <- type
type <- getTypeInfo(type)
} else if (is.TypeInfo(type)) {
name <- type$name
} else {
stop("type is not of class TypeInfo and no character string")
}
if (! type$type %in% c("struct","union") ) stop("type must be C struct or union.")
x <- raw( type$size )
class(x) <- "struct"
attr(x, "struct") <- type$name
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")) {
.unpack(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)], fieldTypeName)
} else if (is.externalptr(x)) {
as.struct( offsetPtr(x, offset), 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 %in% c("base","pointer") ) {
.pack( x, offset, fieldTypeInfo$signature, value )
}
else if ( !is.null(fieldTypeInfo$fields) ) {
# substructure
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)
cat( "struct ", structName, " ")
if (typeof(x) == "externalptr") {
cat ("*")
if (is.nullptr(x)) {
cat("=NULL\n")
return()
}
}
cat("{\n")
# print data without last
for (i in seq(along=fieldNames))
{
cat( rep(" ", indent+1), fieldNames[[i]] , ":" )
val <- unpack.struct(x, fieldNames[[i]])
if (typeof(val) == "externalptr") val <- "ptr" # .extptr2str(val)
if (class(val) == "struct") { print.struct(val, indent=indent+1) }
else cat( val, "\n" )
}
cat( rep(" ", indent), "}\n")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.