|
0
|
1 # Package: rdyncall
|
|
|
2 # File: R/dynstruct.R
|
|
|
3 # Description: Handling of aggregate (struct/union) C types
|
|
|
4
|
|
|
5 # ----------------------------------------------------------------------------
|
|
|
6 # dynport basetype sizes
|
|
|
7
|
|
|
8 .basetypeSizes <- c(
|
|
|
9 B=.Machine$sizeof.long,
|
|
|
10 c=1,
|
|
|
11 C=1,
|
|
|
12 s=2,
|
|
|
13 S=2,
|
|
|
14 i=4,
|
|
|
15 I=4,
|
|
|
16 j=.Machine$sizeof.long,
|
|
|
17 J=.Machine$sizeof.long,
|
|
|
18 l=.Machine$sizeof.longlong,
|
|
|
19 L=.Machine$sizeof.longlong,
|
|
|
20 f=4,
|
|
|
21 d=8,
|
|
|
22 p=.Machine$sizeof.pointer,
|
|
|
23 x=.Machine$sizeof.pointer,
|
|
|
24 Z=.Machine$sizeof.pointer,
|
|
|
25 v=0
|
|
|
26 )
|
|
|
27
|
|
|
28 # ----------------------------------------------------------------------------
|
|
|
29 # dynport type information
|
|
|
30 #
|
|
|
31
|
|
|
32 TypeInfo <- function(name, type = c("base","pointer","struct","union"), size = NA, align = NA, basetype = NA, fields = NA, signature = NA)
|
|
|
33 {
|
|
|
34 type <- match.arg(type)
|
|
|
35 x <- list(name = name, type = type, size = size, align = align, basetype = basetype, fields = fields, signature = signature)
|
|
|
36 class(x) <- "typeinfo"
|
|
|
37 return(x)
|
|
|
38 }
|
|
|
39
|
|
|
40 is.TypeInfo <- function(x)
|
|
|
41 {
|
|
|
42 inherits(x, "typeinfo")
|
|
|
43 }
|
|
|
44
|
|
|
45 getTypeInfo <- function(name, envir=parent.frame())
|
|
|
46 {
|
|
|
47 if (is.character(name)) {
|
|
|
48 getTypeInfoByName(name, envir)
|
|
|
49 } else if (is.TypeInfo(name)) {
|
|
|
50 name
|
|
|
51 } else {
|
|
|
52 stop("unknown type")
|
|
|
53 }
|
|
|
54 }
|
|
|
55
|
|
|
56 getTypeInfoByName <- function(typeName, envir=parent.frame())
|
|
|
57 {
|
|
|
58 char1 <- substr(typeName, 1, 1)
|
|
|
59 switch(char1,
|
|
|
60 "*"=TypeInfo(name=typeName, type="pointer", size=.Machine$sizeof.pointer, align=.Machine$sizeof.pointer, basetype=substr(typeName,2,nchar(typeName)), signature=typeName),
|
|
|
61 "<"={
|
|
|
62 x <- getTypeInfo(substr(typeName, 2,nchar(typeName)-1), envir=envir)
|
|
|
63 if (!is.null(x))
|
|
|
64 return(x)
|
|
|
65 else
|
|
|
66 return(TypeInfo(name=typeName, type="struct"))
|
|
|
67 },
|
|
|
68 {
|
|
|
69 # try as basetype
|
|
|
70 basetypeSize <- unname(.basetypeSizes[typeName])
|
|
|
71 if ( !is.na(basetypeSize) ) return(TypeInfo(name=typeName,type="base", size=basetypeSize, align=basetypeSize, signature=typeName))
|
|
|
72 # try lookup symbol
|
|
|
73 else if (exists(typeName,envir=envir) ) {
|
|
|
74 info <- get(typeName,envir=envir)
|
|
|
75 if (!inherits(info, "typeinfo")) stop("not a type information symbol")
|
|
|
76 return(info)
|
|
|
77 }
|
|
|
78 # otherwise fail
|
|
|
79 else NULL
|
|
|
80 # else stop("unknown type info: ",typeName)
|
|
|
81 }
|
|
|
82 )
|
|
|
83 }
|
|
|
84
|
|
|
85 # ----------------------------------------------------------------------------
|
|
|
86 # align C offsets
|
|
|
87
|
|
|
88 align <- function(offset, alignment)
|
|
|
89 {
|
|
|
90 as.integer( as.integer( (offset + alignment-1) / alignment ) * alignment )
|
|
|
91 }
|
|
|
92
|
|
|
93 # ----------------------------------------------------------------------------
|
|
|
94 # field information (structures and unions)
|
|
|
95
|
|
|
96 makeFieldInfo <- function(fieldNames, types, offsets)
|
|
|
97 {
|
|
|
98 data.frame(type=I(types), offset=offsets, row.names=fieldNames)
|
|
|
99 }
|
|
|
100
|
|
|
101 # ----------------------------------------------------------------------------
|
|
|
102 # parse structure signature
|
|
|
103
|
|
|
104 makeStructInfo <- function(name, signature, fieldNames, envir=parent.frame())
|
|
|
105 {
|
|
|
106 # computations:
|
|
|
107 types <- character()
|
|
|
108 offsets <- integer()
|
|
|
109 offset <- 0
|
|
|
110 maxAlign <- 1
|
|
|
111 # scan variables:
|
|
|
112 n <- nchar(signature)
|
|
|
113 i <- 1
|
|
|
114 start <- i
|
|
|
115 while(i <= n)
|
|
|
116 {
|
|
|
117 char <- substr(signature,i,i)
|
|
|
118 if (char == "*") {
|
|
|
119 i <- i + 1 ; next
|
|
|
120 } else if (char == "<") {
|
|
|
121 i <- i + 1
|
|
|
122 while (i < n) {
|
|
|
123 if ( substr(signature,i,i) == ">" ) break
|
|
|
124 i <- i + 1
|
|
|
125 }
|
|
|
126 }
|
|
|
127 typeName <- substr(signature, start, i)
|
|
|
128 types <- c(types, typeName)
|
|
|
129 typeInfo <- getTypeInfo(typeName, envir=envir)
|
|
|
130 alignment <- typeInfo$align
|
|
|
131 maxAlign <- max(maxAlign, alignment)
|
|
|
132 offset <- align( offset, alignment )
|
|
|
133 offsets <- c(offsets, offset)
|
|
|
134
|
|
|
135 # increment offset by size
|
|
|
136 offset <- offset + typeInfo$size
|
|
|
137
|
|
|
138 # next token
|
|
|
139 i <- i + 1
|
|
|
140 start <- i
|
|
|
141 }
|
|
|
142 # align the structure size (compiler-specific?)
|
|
|
143 size <- align(offset, maxAlign)
|
|
|
144 # build field information
|
|
|
145 fields <- makeFieldInfo(fieldNames, types, offsets)
|
|
|
146 TypeInfo(name=name,type="struct",size=size,align=maxAlign,fields=fields)
|
|
|
147 }
|
|
|
148
|
|
|
149 parseStructInfos <- function(sigs, envir=parent.frame())
|
|
|
150 {
|
|
|
151 # split functions at ';'
|
|
|
152 sigs <- unlist( strsplit(sigs, ";") )
|
|
|
153 # split name/struct signature at '('
|
|
|
154 sigs <- strsplit(sigs, "[{]")
|
|
|
155 infos <- list()
|
|
|
156 for (i in seq(along=sigs))
|
|
|
157 {
|
|
|
158 n <- length(sigs[[i]])
|
|
|
159 if ( n == 2 ) {
|
|
|
160 # parse structure name
|
|
|
161 name <- sigs[[i]][[1]]
|
|
|
162 name <- gsub("[ \n\t]*","",name)
|
|
|
163 # split struct signature and field names
|
|
|
164 tail <- unlist( strsplit(sigs[[i]][[2]], "[}]") )
|
|
|
165 sig <- tail[[1]]
|
|
|
166 if (length(tail) == 2)
|
|
|
167 fields <- unlist( strsplit( tail[[2]], "[ \n\t]+" ) )
|
|
|
168 else
|
|
|
169 fields <- NULL
|
|
|
170 assign(name, makeStructInfo(name, sig, fields, envir=envir), envir=envir)
|
|
|
171 }
|
|
|
172 }
|
|
|
173 }
|
|
|
174
|
|
|
175 # ----------------------------------------------------------------------------
|
|
|
176 # parse union signature
|
|
|
177
|
|
|
178 makeUnionInfo <- function(name, signature, fieldNames, envir=parent.frame())
|
|
|
179 {
|
|
|
180 # computations:
|
|
|
181 types <- character()
|
|
|
182 maxSize <- 0
|
|
|
183 maxAlign <- 1
|
|
|
184 # scan variables:
|
|
|
185 i <- 1
|
|
|
186 start <- i
|
|
|
187 n <- nchar(signature)
|
|
|
188 while(i <= n) {
|
|
|
189 char <- substr(signature,i,i)
|
|
|
190 if (char == "*") {
|
|
|
191 i <- i + 1 ; next
|
|
|
192 } else if (char == "<") {
|
|
|
193 i <- i + 1
|
|
|
194 while (i < n) {
|
|
|
195 if ( substr(signature,i,i) == ">" ) break
|
|
|
196 i <- i + 1
|
|
|
197 }
|
|
|
198 }
|
|
|
199 typeName <- substr(signature,start,i)
|
|
|
200 types <- c(types, typeName)
|
|
|
201 typeInfo <- getTypeInfo(typeName, envir)
|
|
|
202 maxSize <- max( maxSize, typeInfo$size )
|
|
|
203 maxAlign <- max( maxAlign, typeInfo$align )
|
|
|
204 # next token
|
|
|
205 i <- i + 1
|
|
|
206 start <- i
|
|
|
207 }
|
|
|
208 offsets <- rep(0, length(types) )
|
|
|
209 fields <- makeFieldInfo(fieldNames, types, offsets)
|
|
|
210 TypeInfo(name=name, type="union", fields=fields, size=maxSize, align=maxAlign)
|
|
|
211 }
|
|
|
212
|
|
|
213 parseUnionInfos <- function(sigs, envir=parent.frame())
|
|
|
214 {
|
|
|
215 # split functions at ';'
|
|
|
216 sigs <- unlist( strsplit(sigs, ";") )
|
|
|
217 # split name/union signature at '|'
|
|
|
218 sigs <- strsplit(sigs, "[|]")
|
|
|
219 infos <- list()
|
|
|
220 for (i in seq(along=sigs))
|
|
|
221 {
|
|
|
222 n <- length(sigs[[i]])
|
|
|
223 if ( n == 2 ) {
|
|
|
224 # parse union name
|
|
|
225 name <- sigs[[i]][[1]]
|
|
|
226 name <- gsub("[ \n\t]*","",name)
|
|
|
227 # split union signature and field names
|
|
|
228 tail <- unlist( strsplit(sigs[[i]][[2]], "[}]") )
|
|
|
229 sig <- tail[[1]]
|
|
|
230 if (length(tail) == 2)
|
|
|
231 fields <- unlist( strsplit( tail[[2]], "[ \n\t]+" ) )
|
|
|
232 else
|
|
|
233 fields <- NULL
|
|
|
234 assign( name, makeUnionInfo(name, sig, fields, envir=envir), envir=envir )
|
|
|
235 }
|
|
|
236 }
|
|
|
237 }
|
|
|
238
|
|
|
239
|
|
|
240 # ----------------------------------------------------------------------------
|
|
|
241 # raw backed struct's (S3 Class)
|
|
|
242
|
|
|
243 as.struct <- function(x, type)
|
|
|
244 {
|
|
|
245 if (is.TypeInfo(x)) structName <- type$name
|
|
|
246 attr(x, "struct") <- type
|
|
|
247 class(x) <- "struct"
|
|
|
248 return(x)
|
|
|
249 }
|
|
|
250
|
|
|
251 new.struct <- function(type)
|
|
|
252 {
|
|
|
253 if (is.character(type)) {
|
|
|
254 name <- type
|
|
|
255 type <- getTypeInfo(type)
|
|
|
256 } else if (is.TypeInfo(type)) {
|
|
|
257 name <- type$name
|
|
|
258 } else {
|
|
|
259 stop("type is not of class TypeInfo and no character string")
|
|
|
260 }
|
|
|
261 if (! type$type %in% c("struct","union") ) stop("type must be C struct or union.")
|
|
|
262 x <- raw( type$size )
|
|
|
263 class(x) <- "struct"
|
|
|
264 attr(x, "struct") <- type$name
|
|
|
265 return(x)
|
|
|
266 }
|
|
|
267
|
|
|
268 "$.struct" <-
|
|
|
269 unpack.struct <- function(x, index)
|
|
|
270 {
|
|
|
271 structName <- attr(x, "struct")
|
|
|
272 structInfo <- getTypeInfo(structName)
|
|
|
273 fieldInfos <- structInfo$fields
|
|
|
274 offset <- fieldInfos[index,"offset"]
|
|
|
275 if (is.na(offset)) stop("unknown field index '", index ,"'")
|
|
|
276 fieldTypeName <- as.character(fieldInfos[[index,"type"]])
|
|
|
277 fieldTypeInfo <- getTypeInfo(fieldTypeName)
|
|
|
278 if (fieldTypeInfo$type %in% c("base","pointer")) {
|
|
|
279 .unpack(x, offset, fieldTypeInfo$signature)
|
|
|
280 } else if ( !is.null(fieldTypeInfo$fields) ) {
|
|
|
281 if (is.raw(x)) {
|
|
|
282 size <- fieldTypeInfo$size
|
|
|
283 as.struct( x[(offset+1):(offset+1+size-1)], fieldTypeName)
|
|
|
284 } else if (is.externalptr(x)) {
|
|
|
285 as.struct( offsetPtr(x, offset), fieldTypeName)
|
|
|
286 }
|
|
|
287 } else {
|
|
|
288 stop("invalid field type '", fieldTypeName,"' at field '", index )
|
|
|
289 }
|
|
|
290 }
|
|
|
291
|
|
|
292 "$<-.struct" <-
|
|
|
293 pack.struct <- function( x, index, value )
|
|
|
294 {
|
|
|
295 structName <- attr(x, "struct")
|
|
|
296 structInfo <- getTypeInfo(structName)
|
|
|
297 fieldInfos <- structInfo$fields
|
|
|
298 offset <- fieldInfos[index,"offset"]
|
|
|
299 if (is.na(offset)) stop("unknown field index '", index ,"'")
|
|
|
300 fieldTypeName <- as.character(fieldInfos[index,"type"])
|
|
|
301 fieldTypeInfo <- getTypeInfo(fieldTypeName)
|
|
|
302 if ( fieldTypeInfo$type %in% c("base","pointer") ) {
|
|
|
303 .pack( x, offset, fieldTypeInfo$signature, value )
|
|
|
304 }
|
|
|
305 else if ( !is.null(fieldTypeInfo$fields) ) {
|
|
|
306 # substructure
|
|
|
307 size <- fieldTypeInfo$size
|
|
|
308 x[(offset+1):(offset+1+size-1)] <- as.raw(value)
|
|
|
309 }
|
|
|
310 else {
|
|
|
311 stop("invalid field type '", fieldTypeName,"' at field '", index )
|
|
|
312 }
|
|
|
313 return(x)
|
|
|
314 }
|
|
|
315
|
|
|
316 print.struct <- function(x, indent=0, ...)
|
|
|
317 {
|
|
|
318 structName <- attr(x, "struct")
|
|
|
319 structInfo <- getTypeInfo(structName)
|
|
|
320 fieldInfos <- structInfo$fields
|
|
|
321 fieldNames <- rownames(fieldInfos)
|
|
|
322
|
|
|
323 cat( "struct ", structName, " ")
|
|
|
324 if (typeof(x) == "externalptr") {
|
|
|
325 cat ("*")
|
|
|
326 if (is.nullptr(x)) {
|
|
|
327 cat("=NULL\n")
|
|
|
328 return()
|
|
|
329 }
|
|
|
330 }
|
|
|
331 cat("{\n")
|
|
|
332 # print data without last
|
|
|
333 for (i in seq(along=fieldNames))
|
|
|
334 {
|
|
|
335 cat( rep(" ", indent+1), fieldNames[[i]] , ":" )
|
|
|
336 val <- unpack.struct(x, fieldNames[[i]])
|
|
|
337 if (typeof(val) == "externalptr") val <- "ptr" # .extptr2str(val)
|
|
|
338 if (class(val) == "struct") { print.struct(val, indent=indent+1) }
|
|
|
339 else cat( val, "\n" )
|
|
|
340 }
|
|
|
341 cat( rep(" ", indent), "}\n")
|
|
|
342 }
|
|
|
343
|
