wingo pushed a commit to branch main
in repository guile.
commit d7ae468c170454d807bd0dd29ae309ffa4f448ce
Author: Andy Wingo <wi...@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)
