summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2024-03-17 20:56:21 +0100
committerAndy Wingo <wingo@pobox.com>2024-03-17 21:40:58 +0100
commitd7ae468c170454d807bd0dd29ae309ffa4f448ce (patch)
tree6e346f81267ec112ef4c6db503d6c5d31b64d7f7 /module/system
parent7fef214f6e0df4004020fec530e808c476f2d2bf (diff)
downloadguile-d7ae468c170454d807bd0dd29ae309ffa4f448ce.tar.gz
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.
Diffstat (limited to 'module/system')
-rw-r--r--module/system/foreign.scm34
1 files 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)