[Guile-commits] 05/06: Rework read-fields, write-fields to not return offset

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit d7ae468c170454d807bd0dd29ae309ffa4f448ce
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sun Mar 17 20:56:21 2024 +0100

    Rework read-fields, write-fields to not return offset
    
    * module/system/foreign.scm (read-fields, write-fields): Don't return
    the final offset, as the offset after the final field is not necessarily
    the end of the struct, because of padding.
---
 module/system/foreign.scm | 34 ++++++++++++++++++++--------------
 1 file changed, 20 insertions(+), 14 deletions(-)

diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 438ecd5ed..043d34409 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -21,6 +21,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (system base target)
   #:export (void
             float double
@@ -177,14 +178,16 @@ not cross-compiling; otherwise leave it to be evaluated 
at run-time."
      (complex-double bytevector-complex-double-native-ref)
      ('* bytevector-pointer-ref))))
 
-(define-syntax read-fields
-  (syntax-rules ()
-    ((read-fields () bv offset k) (k offset))
-    ((read-fields ((field type) . rest) bv offset k)
-     (call-with-values (lambda ()
-                         (read-field bv offset (compile-time-eval type)))
-       (lambda (field offset)
-         (read-fields rest bv offset k))))))
+(define-syntax-rule (read-fields %bv %offset ((field type) ...) k)
+  (let ((bv %bv)
+        (offset %offset)
+        (size (compile-time-eval (sizeof '(type ...)))))
+    (unless (<= (bytevector-length bv) (+ offset size))
+      (error "destination bytevector too small"))
+    (let*-values (((field offset)
+                   (read-field bv offset (compile-time-eval type)))
+                  ...)
+      (k field ...))))
 
 (define-syntax-rule (write-field %bv %offset %type %value)
   (let ((bv %bv)
@@ -220,12 +223,15 @@ not cross-compiling; otherwise leave it to be evaluated 
at run-time."
      (complex-double bytevector-complex-double-native-set!)
      ('* bytevector-pointer-set!))))
 
-(define-syntax write-fields
-  (syntax-rules ()
-    ((write-fields () bv offset k) (k offset))
-    ((write-fields ((field type) . rest) bv offset k)
-     (let ((offset (write-field bv offset (compile-time-eval type) field)))
-       (write-fields rest bv offset k)))))
+(define-syntax-rule (write-fields %bv %offset ((field type) ...))
+  (let ((bv %bv)
+        (offset %offset)
+        (size (compile-time-eval (sizeof '(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)