[Guile-commits] 06/06: Expose read-c-struct, write-c-struct syntax

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit e15617dc0e1e53a54798d88617f0095801a52f1c
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sun Mar 17 21:39:16 2024 +0100

    Expose read-c-struct, write-c-struct syntax
    
    * module/system/foreign.scm (read-c-struct): Rename from read-fields.
    Export.
    (write-c-struct): Rename from write-fields.  Export.
    (%write-c-struct, %read-c-struct): Add % prefix to these private
    bindings.
---
 doc/ref/api-foreign.texi  | 58 +++++++++++++++++++++++++++++++++++++++--------
 module/system/foreign.scm | 26 +++++++++++----------
 2 files changed, 63 insertions(+), 21 deletions(-)

diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 540fbbaf5..bd250f069 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000-2004, 2007-2014, 2016-2017, 2021
+@c Copyright (C)  1996, 1997, 2000-2004, 2007-2014, 2016-2017, 2021, 2024
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -761,24 +761,64 @@ also be a list of types, in which case the alignment of a
 @code{struct} with ABI-conventional packing is returned.
 @end deffn
 
-Guile also provides some convenience methods to pack and unpack foreign
-pointers wrapping C structs.
+Guile also provides some convenience syntax to efficiently read and
+write C structs to and from bytevectors.
 
-@deffn {Scheme Procedure} make-c-struct types vals
-Create a foreign pointer to a C struct containing @var{vals} with types
-@code{types}.
+@deffn {Scheme Syntax} read-c-struct bv offset @* ((field type) @dots{}) k
+Read a C struct with fields of type @var{type}... from the bytevector
+@var{bv}, at offset @var{offset}.  Bind the fields to the identifiers
+@var{field}..., and return @code{(@var{k} @var{field} ...)}.
 
-@var{vals} and @code{types} should be lists of the same length.
+Unless cross-compiling, the field types are evaluated at macro-expansion
+time.  This allows the resulting bytevector accessors and size/alignment
+computations to be completely inlined.
 @end deffn
 
+@deffn {Scheme Syntax} write-c-struct bv offset @* ((field type) @dots{})
+Write a C struct with fields @var{field}... of type @var{type}... to the 
bytevector
+@var{bv}, at offset @var{offset}.  Return zero values.
+
+Like @code{write-c-struct} above, unless cross-compiling, the field
+types are evaluated at macro-expansion time.
+@end deffn
+
+For example, to define a parser and serializer for the equivalent of a
+@code{struct @{ int64_t a; uint8_t b; @}}, one might do this:
+
+@example
+(use-modules (system foreign) (rnrs bytevectors))
+
+(define-syntax-rule
+    (define-serialization (reader writer) (field type) ...)
+  (begin
+    (define (reader bv offset)
+      (read-c-struct bv offset ((field type) ...) values))
+    (define (writer bv offset field ...)
+      (write-c-struct bv offset ((field type) ...)))))
+
+(define-serialization (read-struct write-struct)
+  (a int64) (b uint8))
+
+(define bv (make-bytevector (sizeof (list int64 uint8))))
+
+(write-struct bv 0 300 43)
+(call-with-values (lambda () (read-struct bv 0))
+  list)
+@result{} (300 43)
+@end example
+
+There is also an older interface that is mostly equivalent to
+@code{read-c-struct} and @code{write-c-struct}, but which uses run-time
+dispatch, and operates on foreign pointers instead of bytevectors.
+
 @deffn {Scheme Procedure} parse-c-struct foreign types
 Parse a foreign pointer to a C struct, returning a list of values.
 
 @code{types} should be a list of C types.
 @end deffn
 
-For example, to create and parse the equivalent of a @code{struct @{
-int64_t a; uint8_t b; @}}:
+Our parser and serializer example for @code{struct @{ int64_t a; uint8_t
+b; @}} looks more like this:
 
 @example
 (parse-c-struct (make-c-struct (list int64 uint8)
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 043d34409..a75c37da1 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -55,6 +55,8 @@
 
             pointer->procedure
             ;; procedure->pointer (see below)
+
+            read-c-struct write-c-struct
             make-c-struct parse-c-struct
 
             define-wrapped-pointer-type))
@@ -160,7 +162,7 @@ not cross-compiling; otherwise leave it to be evaluated at 
run-time."
        (... ...)
        (else
         (let ((offset (align offset (alignof type))))
-          (values (read-c-struct bv offset type)
+          (values (%read-c-struct bv offset type)
                   (+ offset (sizeof type)))))))
     (dispatch-read
      type
@@ -178,10 +180,10 @@ not cross-compiling; otherwise leave it to be evaluated 
at run-time."
      (complex-double bytevector-complex-double-native-ref)
      ('* bytevector-pointer-ref))))
 
-(define-syntax-rule (read-fields %bv %offset ((field type) ...) k)
+(define-syntax-rule (read-c-struct %bv %offset ((field type) ...) k)
   (let ((bv %bv)
         (offset %offset)
-        (size (compile-time-eval (sizeof '(type ...)))))
+        (size (compile-time-eval (sizeof (list type ...)))))
     (unless (<= (bytevector-length bv) (+ offset size))
       (error "destination bytevector too small"))
     (let*-values (((field offset)
@@ -205,7 +207,7 @@ not cross-compiling; otherwise leave it to be evaluated at 
run-time."
        (... ...)
        (else
         (let ((offset (align offset (alignof type))))
-          (write-c-struct bv offset type value)
+          (%write-c-struct bv offset type value)
           (+ offset (sizeof type))))))
     (dispatch-write
      type
@@ -223,18 +225,18 @@ not cross-compiling; otherwise leave it to be evaluated 
at run-time."
      (complex-double bytevector-complex-double-native-set!)
      ('* bytevector-pointer-set!))))
 
-(define-syntax-rule (write-fields %bv %offset ((field type) ...))
+(define-syntax-rule (write-c-struct %bv %offset ((field type) ...))
   (let ((bv %bv)
         (offset %offset)
-        (size (compile-time-eval (sizeof '(type ...)))))
+        (size (compile-time-eval (sizeof (list type ...)))))
     (unless (<= (bytevector-length bv) (+ offset size))
       (error "destination bytevector too small"))
     (let* ((offset (write-field bv offset (compile-time-eval type) field))
            ...)
       (values))))
 
-;; Same as write-fields, but with run-time dispatch.
-(define (write-c-struct bv offset types vals)
+;; Same as write-c-struct, but with run-time dispatch.
+(define (%write-c-struct bv offset types vals)
   (let lp ((offset offset) (types types) (vals vals))
     (match types
       (() (match vals
@@ -246,8 +248,8 @@ not cross-compiling; otherwise leave it to be evaluated at 
run-time."
           (lp (write-field bv offset type val) types vals))
          (() (error "too few values" vals)))))))
 
-;; Same as read-fields, but with run-time dispatch.
-(define (read-c-struct bv offset types)
+;; Same as read-c-struct, but with run-time dispatch.
+(define (%read-c-struct bv offset types)
   (let lp ((offset offset) (types types))
     (match types
       (() '())
@@ -258,11 +260,11 @@ not cross-compiling; otherwise leave it to be evaluated 
at run-time."
 
 (define (make-c-struct types vals)
   (let ((bv (make-bytevector (sizeof types) 0)))
-    (write-c-struct bv 0 types vals)
+    (%write-c-struct bv 0 types vals)
     (bytevector->pointer bv)))
 
 (define (parse-c-struct foreign types)
-  (read-c-struct (pointer->bytevector foreign (sizeof types)) 0 types))
+  (%read-c-struct (pointer->bytevector foreign (sizeof types)) 0 types))
 
 
 ;;;