mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Rework read-fields, write-fields to not return offset

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2024-03-17 20:56:21 +01:00
parent 7fef214f6e
commit d7ae468c17
1 changed files with 20 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/system/foreign.scm
View file

@ -21,6 +21,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (system base target) #:use-module (system base target)
#:export (void #:export (void
float double 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) (complex-double bytevector-complex-double-native-ref)
('* bytevector-pointer-ref)))) ('* bytevector-pointer-ref))))
(define-syntax read-fields (define-syntax-rule (read-fields %bv %offset ((field type) ...) k)
(syntax-rules () (let ((bv %bv)
((read-fields () bv offset k) (k offset)) (offset %offset)
((read-fields ((field type) . rest) bv offset k) (size (compile-time-eval (sizeof '(type ...)))))
(call-with-values (lambda () (unless (<= (bytevector-length bv) (+ offset size))
(read-field bv offset (compile-time-eval type))) (error "destination bytevector too small"))
(lambda (field offset) (let*-values (((field offset)
(read-fields rest bv offset k)))))) (read-field bv offset (compile-time-eval type)))
...)
(k field ...))))
(define-syntax-rule (write-field %bv %offset %type %value) (define-syntax-rule (write-field %bv %offset %type %value)
(let ((bv %bv) (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!) (complex-double bytevector-complex-double-native-set!)
('* bytevector-pointer-set!)))) ('* bytevector-pointer-set!))))
(define-syntax write-fields (define-syntax-rule (write-fields %bv %offset ((field type) ...))
(syntax-rules () (let ((bv %bv)
((write-fields () bv offset k) (k offset)) (offset %offset)
((write-fields ((field type) . rest) bv offset k) (size (compile-time-eval (sizeof '(type ...)))))
(let ((offset (write-field bv offset (compile-time-eval type) field))) (unless (<= (bytevector-length bv) (+ offset size))
(write-fields rest bv offset k))))) (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. ;; Same as write-fields, but with run-time dispatch.
(define (write-c-struct bv offset types vals) (define (write-c-struct bv offset types vals)