suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add package serialize-cstruct-lib for cpointer serialization

Browse Source 
* define-serializable-cstruct is a combination of serializable-struct and define-cstruct.
  It defines serialize and deserialize functions for a limited subset of cstructs, that
  may contain primitive types, arrays, other serializable cstructs embedded or via pointer.
  Cases handled include: self-referencing cstructs, cyclic cstructs and shared pointers
* Tests and documentation are included
This commit is contained in:
Tobias Hammer 2013-08-27 16:19:05 +02:00 committed by Matthew Flatt
parent 62f7731c36
commit 49fec550c9
9 changed files with 654 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/main-distribution/info.rkt
View File

@ -55,6 +55,7 @@
"sandbox-lib"
"schemeunit"
"scribble"
"serialize-cstruct-lib"
"sgl"
"shell-completion"
"slatex"

3
pkgs/racket-pkgs/racket-doc/info.rkt
View File

@ -38,7 +38,8 @@
"scribble"
"compatibility-lib"
"future-visualizer"
"distributed-places-doc"))
"distributed-places-doc"
"serialize-cstruct-lib"))
(define pkg-desc "Base Racket documentation")

1
pkgs/racket-pkgs/racket-doc/scribblings/foreign/derived.scrbl
View File

@ -8,6 +8,7 @@
@include-section["vector.scrbl"]
@include-section["cvector.scrbl"]
@include-section["cpointer.scrbl"]
@include-section["serialize-cstruct.scrbl"]
@include-section["define.scrbl"]
@include-section["alloc.scrbl"]
@include-section["custodian.scrbl"]

60
pkgs/racket-pkgs/racket-doc/scribblings/foreign/serialize-cstruct.scrbl Normal file
View File

@ -0,0 +1,60 @@
#lang scribble/doc
@(require "utils.rkt"
(for-label racket/serialize
ffi/serialize-cstruct)
scribble/racket)
@title[#:tag "serialize-struct"]{Serializable C Struct Types}
@defmodule[ffi/serialize-cstruct]
@defform/subs[(define-serializable-cstruct _id ([field-id type-expr] ...)
property ...)
[(property (code:line #:alignment alignment-expr)
(code:line #:malloc-mode malloc-mode-expr)
(code:line #:serialize-inplace)
(code:line #:deserialize-inplace)
(code:line #:property prop-expr val-expr))]]{
Like @racket[define-cstruct], but defines a serializable type.
In addition to the bindings created by @racket[define-cstruct],
@racketidfont{make-@racketvarfont{id}/mode} is bound to a function that behaves
like @racketidfont{make-@racketvarfont{id}} but uses the mode or allocator
specified via @racket[malloc-mode-expr].
Instances of the new type fulfill the @racket[serializable?] predicate and can
be used with @racket[serialize] and @racket[deserialize]. Serialization may
fail if one of the fields contains an arbitrary pointer, an embedded
non-serializable C struct, or a pointer to a non-serializable C struct.
Array-types are supported as long as they don't contain one of these types.
The @racket[malloc-mode-expr] arguments control the memory allocation
for this type during deserialization and
@racketidfont{make-@racketvarfont{id}/mode}. It can be one of the mode
arguments to @racket[malloc], or a procedure
@;
@racketblock[(-> exact-positive-integer? cpointer?)]
@;
that allocates memory of the given size. The default is
@racket[malloc] with @racket['atomic].
When @racket[#:serialize-inplace] is specified, the serialized
representation shares memory with the C struct object. While being more
efficient, especially for large objects, changes to the object after
serialization may lead to changes in the serialized representation.
A @racket[#:deserialize-inplace] option reuses the memory of the serialized
representation, if possible. This option is more efficient for large objects,
but it may fall back to allocation via @racket[malloc-mode-expr] for cyclic
structures. As the allocation mode of the serialized representation
will be @racket['atomic] by default or may be arbitrary if
@racket[#:serialize-inplace] is specified, inplace deserialisation
should be used with caution whenever the object contains pointers.
When the C struct contains pointers, it is advisable to use a custom
allocator. It should be based on a non-moving-memory allocation like
@racket['raw], potentially with manual freeing to avoid memory leaks
after garbage collection.
}

1
pkgs/racket-pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -1215,7 +1215,6 @@ expects arguments for both the super fields and the new ones:
(define b (make-B 1 2 3))
]}
@; ------------------------------------------------------------
@section{C Array Types}

1
pkgs/racket-pkgs/racket-test/info.rkt
View File

@ -21,6 +21,7 @@
"scribble-lib"
"syntax-color-lib"
"typed-racket-lib"
"serialize-cstruct-lib"
;; for random testing:
"redex-lib"))

337
pkgs/racket-pkgs/racket-test/tests/racket/foreign-test.rktl
View File

@ -544,6 +544,343 @@
(err/rt-test (in-array '(1 2 3)) exn:fail:contract?))
;; check cstruct serialization (define-serialize-cstruct must be at module level, can't use (let () ...))
(module mod-cstruct-serialize racket/base
(require (for-syntax racket/base rackunit)
rackunit
racket/serialize
racket/list
ffi/unsafe
ffi/serialize-cstruct)
;; malloc helper
(define current-raw (make-parameter (make-hash)))
(define-syntax-rule (with-free . body)
(parameterize ([current-raw (make-hash)])
(register-finalizer (current-raw) (lambda (h) (for ([(k v) h]) (free k))))
(begin . body)))
(define (malloc/register size/type)
(define m (malloc (if (ctype? size/type)
(ctype-sizeof size/type)
size/type)
'raw))
(hash-set! (current-raw) m #t)
m)
;; run multiple times to better catching gc related errors
(define num-runs 5)
;; --- syntax errors
(begin-for-syntax
(define-syntax-rule (check-exn+rx exn rx thunk)
(begin
(check-exn exn thunk)
(check-exn rx thunk)))
(check-exn+rx exn:fail:syntax? #rx"id must start with"
(lambda () (local-expand #'(define-serializable-cstruct F1a ([a _int])) 'module #f)))
(check-exn+rx exn:fail:syntax? #rx"only allowed in module context"
(lambda () (local-expand #'(define-serializable-cstruct _F1b ([a _int])) 'expression #f)))
(check-exn+rx exn:fail:syntax? #rx"#:property prop:serializable not allowed"
(lambda () (local-expand #'(define-serializable-cstruct _F1c ([a _int]) #:property prop:serializable #f)
'module #f)))
(check-exn+rx exn:fail:syntax? #rx"expected \\[field-id ctype\\]"
(lambda () (local-expand #'(define-serializable-cstruct _F1d ()) 'module #f))))
;; --- misc creation tests
(define-values (prop:tmp prop:tmp? prop:tmp-ref)
(make-struct-type-property 'testprop))
(define-serializable-cstruct _M1 ([a _int]) #:alignment 8)
(define-serializable-cstruct _M2 ([a _int]) #:property prop:tmp 'abc)
(define-serializable-cstruct _M3 ([a _int]) #:malloc-mode 'atomic)
(define-serializable-cstruct _M4 ([a _int]) #:malloc-mode 'raw)
(let ()
(check-not-exn (lambda () (make-M1 123)))
(check-not-exn (lambda () (make-M2 123)))
(check-not-exn (lambda () (make-M3/mode 123)))
(check-not-exn (lambda ()
(define s (make-M4/mode 123))
(free s))))
;; --- test different types
(define-serializable-cstruct _MISC ([d _double] [ad (_array _double 10)]
[i _int] [ai (_array _int 10)])
#:malloc-mode malloc/register)
(define-serializable-cstruct _MISCPTR ([s _string] [as (_array _string 4)]
[b _bytes] [ab (_array _bytes 4)])
#:malloc-mode 'nonatomic)
(for ([i num-runs])
(with-free
(define m (ptr-ref (malloc/register _MISC) _MISC))
(set-MISC-d! m 1.234)
(set-MISC-i! m 456)
(for ([i 10])
(array-set! (MISC-ad m) i (exact->inexact (+ i (* i .1))))
(array-set! (MISC-ai m) i (+ i 5)))
(check-not-exn (lambda () (deserialize (serialize m))))
(define d (deserialize (serialize m)))
(collect-garbage)
(check-equal? (MISC-d d) 1.234)
(check-equal? (MISC-i d) 456)
(for ([i 10])
(check-equal? (array-ref (MISC-ad d) i) (exact->inexact (+ i (* i .1))))
(check-equal? (array-ref (MISC-ai d) i) (+ i 5)))))
(for ([i num-runs])
(define m (ptr-ref (malloc _MISCPTR 'nonatomic) _MISCPTR))
(set-MISCPTR-s! m "str")
(set-MISCPTR-b! m #"bstr")
(define s-list (list "abc" "def" "ghi" "jkl"))
(define b-list (list #"mno" #"pqr" #"stu"))
(for ([s s-list] [b b-list] [i (in-naturals)])
(array-set! (MISCPTR-as m) i s)
(array-set! (MISCPTR-ab m) i b))
(check-not-exn (lambda () (deserialize (serialize m))))
(define d (deserialize (serialize m)))
(collect-garbage)
(check-equal? (MISCPTR-s d) "str")
(check-equal? (MISCPTR-b d) #"bstr")
(for ([s s-list] [b b-list] [i (in-naturals)])
(check-equal? (array-ref (MISCPTR-as d) i) s)
(check-equal? (array-ref (MISCPTR-ab d) i) b)))
;; --- simple failing tests
(define-serializable-cstruct _F4 ([a _int]) #:malloc-mode 'abc)
(define-serializable-cstruct _F40 ([a _fpointer]))
(define-cstruct _F4E ([a _int]))
(define-serializable-cstruct _F41 ([a _F4E]))
(define-serializable-cstruct _F42 ([a _F4E-pointer]))
(define-serializable-cstruct _F43 ([a (_array _F4E 3)]))
(define-serializable-cstruct _F44 ([a (_array _F4E-pointer 3)]))
(define-serializable-cstruct _F45 ([a _pointer]))
(define-serializable-cstruct _F46 ([a (_array _pointer 3)]))
(define-serializable-cstruct _F47 ([a _fpointer]))
(define-serializable-cstruct _F48 ([a (_array _fpointer 3)]))
(with-free
(check-exn exn:fail? (lambda () (make-F4/mode 1)))
(check-exn exn:fail? (lambda () (deserialize (serialize (make-F4 1)))))
(define msg #rx"is not serializable")
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F40) _F40))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F40) _F40)))) ; same: test promise
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F41) _F41))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F42) _F42))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F43) _F43))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F44) _F44))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F45) _F45))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F46) _F46))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F47) _F47))))
(check-exn msg (lambda () (serialize (ptr-ref (malloc _F48) _F48)))))
;; --- test shared pointers
(define-serializable-cstruct _B ([a _int]) #:malloc-mode malloc/register)
(define-serializable-cstruct _C ([b _B-pointer]) #:malloc-mode malloc/register)
(define-serializable-cstruct _D ([b _B-pointer]) #:malloc-mode malloc/register)
(define-serializable-cstruct _A ([c _C-pointer] [d _D-pointer]) #:malloc-mode malloc/register)
(for ([i num-runs])
(with-free
(define b (make-B/mode 123))
(define c (make-C/mode b))
(define d (make-D/mode b))
(define a (make-A/mode c d))
(define s1 (serialize a))
(define ds1 (deserialize s1))
(check-true (ptr-equal? (C-b (A-c ds1)) (D-b (A-d ds1))))
(collect-garbage)
(check-equal? (C-b (A-c a)) (D-b (A-d a)))
(check-equal? (C-b (A-c ds1)) (D-b (A-d ds1)))
(check-equal? (B-a (C-b (A-c ds1))) 123)))
;; --- test cyclic pointers
(define _CY1/fwd (_cpointer/null 'CY1 _pointer
values
(lambda (e) (cast e _pointer _CY1-pointer))))
(define-serializable-cstruct _CY0 ([a _CY1/fwd]) #:malloc-mode malloc/register)
(define-serializable-cstruct _CY1 ([a _CY0-pointer]) #:malloc-mode malloc/register)
(for ([i num-runs])
(with-free
(define cy0 (make-CY0/mode #f))
(define cy1 (make-CY1/mode cy0))
(set-CY0-a! cy0 cy1)
(define s2 (serialize cy1))
(define ds2 (deserialize s2))
(collect-garbage)
(check-equal? cy1 (CY0-a cy0))
(check-equal? cy0 (CY1-a (CY0-a cy0)))
(check-equal? ds2 (CY0-a (CY1-a ds2)))))
;; --- self referencing struct
(define-serializable-cstruct _SELF ([a _SELF-pointer/null]) #:malloc-mode malloc/register)
(for ([i num-runs])
(with-free
(define self (make-SELF/mode #f))
(set-SELF-a! self self)
(cast self _pointer _uintptr)
(cast (SELF-a self) _pointer _uintptr)
(define s3 (serialize self))
s3
(define ds3 (deserialize s3))
ds3
(collect-garbage)
(cast ds3 _pointer _uintptr)
(cast (SELF-a ds3) _pointer _uintptr)
(check-equal? ds3 (SELF-a ds3))
;; ---
(define self2 (make-SELF/mode #f))
(define ds4 (deserialize (serialize self2)))
(collect-garbage)
(check-equal? (SELF-a ds4) #f)))
;; --- struct pointer array and embedded struct array
(define-serializable-cstruct _SINT ([a _int]) #:malloc-mode malloc/register)
(define-serializable-cstruct _PTRAR ([a (_array _SINT-pointer/null 2 5)]) #:malloc-mode malloc/register)
(define-serializable-cstruct _EMBAR ([a (_array _SINT 2 5)]) #:malloc-mode malloc/register)
(for ([i num-runs])
(with-free
(define par (ptr-ref (malloc/register _PTRAR) _PTRAR))
(for* ([i 2] [j 5])
(array-set! (PTRAR-a par) i j (make-SINT/mode (+ 10 j (* i 5)))))
(define ds (deserialize (serialize par)))
(collect-garbage)
(check-true
(for*/and ([i 2] [j 5])
(= (SINT-a (array-ref (PTRAR-a ds) i j)) (+ 10 j (* i 5)))))
;; --
(define ear (ptr-ref (malloc/register _EMBAR) _EMBAR))
(for* ([i 2] [j 5])
(array-set! (EMBAR-a ear) i j (make-SINT/mode (+ 10 j (* i 5)))))
(define ds2 (deserialize (serialize ear)))
(collect-garbage)
(check-true
(for*/and ([i 2] [j 5])
(= (SINT-a (array-ref (EMBAR-a ds2) i j)) (+ 10 j (* i 5)))))))
;; --- array with embedded struct with pointer
(define-serializable-cstruct _TP ([a _int]) #:malloc-mode malloc/register)
(define-serializable-cstruct _TB ([a _TP-pointer]) #:malloc-mode malloc/register)
(define-serializable-cstruct _TS ([a (_array _TB 2)]) #:malloc-mode malloc/register)
(with-free
(define p (make-TP/mode 65))
(define s (ptr-ref (malloc/register _TS) _TS))
(set-TB-a! (array-ref (TS-a s) 0) p)
(set-TB-a! (array-ref (TS-a s) 1) p)
(define ds (deserialize (serialize s)))
(memset p 0 1 _TP)
(check-equal? (TB-a (array-ref (TS-a ds) 0))
(TB-a (array-ref (TS-a ds) 1)))
(check-equal? 65 (TP-a (TB-a (array-ref (TS-a ds) 0)))))
;; --- inplace tests
(define-serializable-cstruct _NOIN ([a _int]))
(define-serializable-cstruct _INS ([a _int]) #:serialize-inplace)
(define-serializable-cstruct _IND ([a _int]) #:deserialize-inplace)
(define-serializable-cstruct _INSD ([a _int])
#:serialize-inplace #:deserialize-inplace
#:malloc-mode (lambda (_) (error "should not get here")))
;; non-inplace + modification
(let ()
(define noin (make-NOIN/mode 123))
(define s (serialize noin))
(set-NOIN-a! noin 0)
(define ds (deserialize s))
(check-equal? (NOIN-a ds) 123)
(for ([e (flatten s)])
(when (bytes? e)
(memset e 0 (bytes-length e) _byte)))
(check-equal? (NOIN-a ds) 123))
;; inplace serialize and test modification
(let ()
(define ins (make-INS/mode 123))
(check-not-exn (lambda () (serialize ins)))
(define s (serialize ins))
(check-not-exn (lambda () (deserialize s)))
;; unmodified
(define ds1 (deserialize s))
(check-equal? 123 (INS-a ds1))
;; modified
(set-INS-a! ins 456)
(define ds2 (deserialize s))
(check-equal? 456 (INS-a ds2)))
;; inplace deser
(let ()
(define ind (ptr-ref (malloc _IND) _IND))
(set-IND-a! ind 123)
(check-not-exn (lambda () (serialize ind)))
(define s (serialize ind))
(check-not-exn (lambda () (deserialize s)))
(define ds (deserialize s))
(check-equal? 123 (IND-a ds)))
;; both inplace, should never malloc
(let ()
(define insd (ptr-ref (malloc _INSD) _INSD))
(set-INSD-a! insd 123)
(check-not-exn (lambda () (serialize insd)))
(define s (serialize insd))
(check-not-exn (lambda () (deserialize s)))
(define ds (deserialize s))
(check-equal? 123 (INSD-a ds))))
(require (only-in 'mod-cstruct-serialize))
;; ----------------------------------------
(report-errs)

244
pkgs/serialize-cstruct-lib/ffi/serialize-cstruct.rkt Normal file
View File

@ -0,0 +1,244 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
racket/serialize
syntax/parse
syntax/stx)
racket/promise
racket/serialize
ffi/unsafe
(only-in '#%foreign ctype-c->scheme))
(provide (rename-out [prop:serialize-cstruct? serializable-cstruct?])
define-serializable-cstruct)
(define-values (prop:serialize-cstruct prop:serialize-cstruct? prop:serialize-cstruct-ref)
(make-struct-type-property 'serialize-cstruct))
(define cpointer-mapping (make-weak-hash))
(define-syntax (define-serializable-cstruct stx)
(syntax-parse stx
[(_ _ID:id ([field-id:id type-expr:expr] ...)
(~or (~optional (~seq #:malloc-mode malloc-mode:expr)
#:name "#:malloc-mode" #:defaults ([malloc-mode #'(quote atomic)]))
(~optional (~seq (~and #:serialize-inplace serialize-inplace-kw))
#:name "#:serialize-inplace")
(~optional (~seq (~and #:deserialize-inplace deserialize-inplace-kw))
#:name "#:deserialize-inplace")
(~optional (~seq #:alignment align-expr:expr)
#:name "#:alignment")
(~seq #:property prop-expr:expr propval-expr:expr))
...)
(unless (eq? (syntax-local-context) 'module)
(raise-syntax-error #f "only allowed in module context" stx))
(unless (stx-pair? #'(type-expr ...))
(raise-syntax-error #f "expected [field-id ctype] ..." stx))
(define id (string->symbol (cadr (or (regexp-match #rx"^_(.*)$" (symbol->string (syntax-e #'_ID)))
(raise-syntax-error #f "id must start with '_'" stx #'_ID)))))
(with-syntax ([_ID-pointer (format-id #'_ID "~a-pointer" #'_ID)]
[(align ...)
(if (attribute align-expr)
(list '#:alignment (attribute align-expr))
null)]
[((props ...) ...)
(map (lambda (p v)
(when (free-identifier=? #'prop:serializable p)
(raise-syntax-error #f "#:property prop:serializable not allowed" stx p))
(list '#:property p v))
(attribute prop-expr) (attribute propval-expr))]
[(acc-list ...) (stx-map (lambda (e) (format-id #'_ID "~a-~a" id e))
#'(field-id ...))]
[(mod-list ...) (stx-map (lambda (e) (format-id #'_ID "set-~a-~a!" id e))
#'(field-id ...))]
[deser-ID (format-id #'_ID "deserialize:cstruct:~a" id)]
[make-ID/mode (format-id #'_ID "make-~a/mode" id)]
[serialize-inplace (and (attribute serialize-inplace-kw) #t)]
[deserialize-inplace (and (attribute deserialize-inplace-kw) #t)])
(syntax/loc stx
(begin
;; the wrapped cstruct
(define-cstruct _ID ([field-id type-expr] ...)
align ...
props ... ...
#:property prop:serializable
(make-serialize-info
(lambda (s)
(force check-all-serializable)
(hash-set! cpointer-mapping s s)
(define inplace-bs (make-sized-byte-string s (ctype-sizeof _ID)))
(define bs
(if serialize-inplace
inplace-bs
(let ([mem (malloc _ID 'atomic)])
(memcpy mem inplace-bs 1 _ID)
(make-sized-byte-string mem (ctype-sizeof _ID)))))
(vector bs (serialize-cstruct-pointers s)))
(quote-syntax deser-ID)
#t
(or (current-load-relative-directory) (current-directory)))
#:property prop:serialize-cstruct
(lambda () (values _ID (list acc-list ...) (list mod-list ...))))
;; malloc according to malloc-mode
(define (malloc-ID)
(if (procedure? malloc-mode)
(malloc-mode (ctype-sizeof _ID))
(malloc _ID malloc-mode)))
;; deserialization proc
(provide deser-ID)
(define deser-ID (id->deserialize-info _ID _ID-pointer deserialize-inplace malloc-ID))
;; mode-aware make-ID
(define (make-ID/mode field-id ...)
(define s (ptr-ref (malloc-ID) _ID))
(mod-list s field-id) ...
s)
;; ctype serializable check (must be delayed to handle cyclic structs)
(define check-all-serializable
(delay
(let ([ctypes (list type-expr ...)])
(for ([ct (in-list ctypes)]
[t (in-list (ctype->layout _ID))]
[n '(field-id ...)])
(define base (ctype-layout-base-type t))
;; fpointer never possible
(when (eq? base 'fpointer)
(error 'serialize-cstruct "~a::~a of type ~a is not serializable" '_ID n t))
;; struct (ptr, embedded), maybe in array
(when (or (list? base)
(eq? base 'pointer))
(define c->s (ctype-c->scheme (array-base-type ct)))
(unless (and c->s (prop:serialize-cstruct? (c->s (malloc _pointer))))
(error 'serialize-cstruct "~a::~a of type ~a is not serializable" '_ID n t))))))) )))]))
(define (array-base-type ct)
(if (vector? (ctype->layout ct))
(array-base-type (array-type ((ctype-c->scheme ct) #f)))
ct))
(define (ctype-layout-base-type v)
(if (vector? v)
(ctype-layout-base-type (vector-ref v 0))
v))
(define (id->deserialize-info _ID _ID-pointer deserialize-inplace malloc-ID)
(make-deserialize-info
(lambda (bs ptrs)
(define s
(if deserialize-inplace
(cast bs _bytes _ID-pointer)
(let ([mem (malloc-ID)])
(memcpy mem bs 1 _ID)
(cast mem _pointer _ID-pointer))))
(deserialize-cstruct-pointers s ptrs)
s)
(lambda ()
(define s (malloc-ID))
(values (cast s _pointer _ID-pointer)
(lambda (s0)
(memcpy s s0 1 _ID))))))
(define ptr-types '(bytes string/ucs-4 string/utf-16 pointer))
(define (serialize-cstruct-pointers o)
(define who 'serialize-cstruct-pointers)
(unless (prop:serialize-cstruct? o)
(raise-argument-error who "serializable-cstruct?" o))
(define-values (_ID accs mods) ((prop:serialize-cstruct-ref o)))
(define (serialize-basic t o)
(cond
[(list? t)
(and o (serialize-cstruct-pointers o))]
[(memq t ptr-types)
(unless (serializable? o)
(raise-argument-error who "serializable?" o))
(hash-ref! cpointer-mapping o o)]))
(for/vector ([t (in-list (ctype->layout _ID))]
[acc (in-list accs)]
#:when (let ([base (ctype-layout-base-type t)])
(when (eq? base 'fpointer)
(raise-argument-error who "serializable?" 'fpointer))
(or (list? base)
(memq base ptr-types))))
(define base (ctype-layout-base-type t))
(cond
[(vector? t)
(let loop ([ar (acc o)])
(define len (array-length ar))
(for/vector #:length len ([i (in-range len)])
(define v (array-ref ar i))
(if (array? v)
(loop v)
(serialize-basic base v))))]
[else
(serialize-basic t (acc o))])))
(define (deserialize-cstruct-pointers o ptrs)
(unless (prop:serialize-cstruct? o)
(raise-argument-error 'deserialize-cstruct-pointers "serializable-cstruct?" o))
(define-values (_ID accs mods) ((prop:serialize-cstruct-ref o)))
(for ([acc (in-list accs)]
[mod (in-list mods)]
[t (in-list (ctype->layout _ID))]
[p (in-vector ptrs)])
(define base (ctype-layout-base-type t))
(cond
[(and (vector? t)
(or (memq base ptr-types)
(list? base)))
(let loop ([ar (acc o)]
[pvec p]
[sub-t t])
(define len (array-length ar))
(if (vector? (vector-ref sub-t 0))
(for ([i (in-range len)]
[pv (in-vector pvec)])
(loop (array-ref ar i) pv (vector-ref sub-t 0)))
(for ([i (in-range len)]
[pv (in-vector pvec)])
(if (list? base)
(deserialize-cstruct-pointers (array-ref ar i) pv)
(array-set! ar i pv)))))]
[(list? t)
(deserialize-cstruct-pointers (acc o) p)]
[(and p (memq t ptr-types))
(mod o p)])))

8
pkgs/serialize-cstruct-lib/info.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang info
(define collection 'multi)
(define deps '("base"))
(define pkg-desc "serialization support for C structs")
(define pkg-authors '("tobias.hammer@dlr.de"))