mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
e15617dc0e
* 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.
298 lines
10 KiB
Scheme
298 lines
10 KiB
Scheme
;;; Copyright (C) 2010-2011,2013-2014,2024 Free Software Foundation, Inc.
|
||
;;;
|
||
;;; This library is free software: you can redistribute it and/or modify
|
||
;;; it under the terms of the GNU Lesser General Public License as
|
||
;;; published by the Free Software Foundation, either version 3 of the
|
||
;;; License, or (at your option) any later version.
|
||
;;;
|
||
;;; This library is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;; Lesser General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU Lesser General Public
|
||
;;; License along with this program. If not, see
|
||
;;; <http://www.gnu.org/licenses/>.
|
||
|
||
|
||
(define-module (system foreign)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (rnrs bytevectors)
|
||
#: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
|
||
complex-float complex-double
|
||
short
|
||
unsigned-short
|
||
int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t
|
||
int8 uint8
|
||
uint16 int16
|
||
uint32 int32
|
||
uint64 int64
|
||
intptr_t uintptr_t
|
||
|
||
sizeof alignof
|
||
|
||
%null-pointer
|
||
null-pointer?
|
||
pointer?
|
||
make-pointer
|
||
pointer->scm
|
||
scm->pointer
|
||
pointer-address
|
||
|
||
pointer->bytevector
|
||
bytevector->pointer
|
||
set-pointer-finalizer!
|
||
|
||
dereference-pointer
|
||
string->pointer
|
||
pointer->string
|
||
|
||
pointer->procedure
|
||
;; procedure->pointer (see below)
|
||
|
||
read-c-struct write-c-struct
|
||
make-c-struct parse-c-struct
|
||
|
||
define-wrapped-pointer-type))
|
||
|
||
(eval-when (expand load eval)
|
||
(load-extension (string-append "libguile-" (effective-version))
|
||
"scm_init_foreign"))
|
||
|
||
|
||
;;;
|
||
;;; Pointers.
|
||
;;;
|
||
|
||
(define (null-pointer? pointer)
|
||
"Return true if POINTER is the null pointer."
|
||
(= (pointer-address pointer) 0))
|
||
|
||
(if (defined? 'procedure->pointer)
|
||
(export procedure->pointer))
|
||
|
||
|
||
;;;
|
||
;;; Structures.
|
||
;;;
|
||
|
||
(define-syntax compile-time-eval
|
||
(lambda (stx)
|
||
"Evaluate the target-dependent expression EXP at compile-time if we are
|
||
not cross-compiling; otherwise leave it to be evaluated at run-time."
|
||
(syntax-case stx ()
|
||
((_ exp)
|
||
(if (equal? (target-type) %host-type)
|
||
#`(quote
|
||
#,(datum->syntax #'here
|
||
(primitive-eval (syntax->datum #'exp))))
|
||
#'exp)))))
|
||
|
||
;; Note that in a cross-compiled Guile, the host and the target may have
|
||
;; different values of, say, `long'. However the explicitly-sized types
|
||
;; int8, float, etc have the same value on all platforms. sizeof on
|
||
;; these types is also a target-invariant primitive. alignof is notably
|
||
;; *not* target-invariant.
|
||
|
||
(define-syntax switch/compile-time-keys
|
||
(syntax-rules (else)
|
||
((_ x (k expr) ... (else alt))
|
||
(let ((t x))
|
||
(cond
|
||
((eq? t (compile-time-eval k)) expr)
|
||
...
|
||
(else alt))))))
|
||
|
||
(define-syntax-rule (align off alignment)
|
||
(1+ (logior (1- off) (1- alignment))))
|
||
|
||
(define bytevector-pointer-ref
|
||
(case (sizeof '*)
|
||
((8) (lambda (bv offset)
|
||
(make-pointer (bytevector-u64-native-ref bv offset))))
|
||
((4) (lambda (bv offset)
|
||
(make-pointer (bytevector-u32-native-ref bv offset))))
|
||
(else (error "what machine is this?"))))
|
||
|
||
(define bytevector-pointer-set!
|
||
(case (sizeof '*)
|
||
((8) (lambda (bv offset ptr)
|
||
(bytevector-u64-native-set! bv offset (pointer-address ptr))))
|
||
((4) (lambda (bv offset ptr)
|
||
(bytevector-u32-native-set! bv offset (pointer-address ptr))))
|
||
(else (error "what machine is this?"))))
|
||
|
||
(define-syntax-rule (define-complex-accessors (read write) (%read %write size))
|
||
(begin
|
||
(define (read bv offset)
|
||
(make-rectangular
|
||
(%read bv offset)
|
||
(%read bv (+ offset size))))
|
||
(define (write bv offset val)
|
||
(%write bv offset (real-part val))
|
||
(%write bv (+ offset size) (imag-part val)))))
|
||
|
||
(define-complex-accessors
|
||
(bytevector-complex-single-native-ref bytevector-complex-single-native-set!)
|
||
(bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! 4))
|
||
|
||
(define-complex-accessors
|
||
(bytevector-complex-double-native-ref bytevector-complex-double-native-set!)
|
||
(bytevector-ieee-double-native-ref bytevector-ieee-double-native-set! 8))
|
||
|
||
(define-syntax-rule (read-field %bv %offset %type)
|
||
(let ((bv %bv)
|
||
(offset %offset)
|
||
(type %type))
|
||
(define-syntax-rule (%read type reader)
|
||
(let* ((offset (align offset (compile-time-eval (alignof type))))
|
||
(val (reader bv offset)))
|
||
(values val
|
||
(+ offset (compile-time-eval (sizeof type))))))
|
||
(define-syntax-rule (dispatch-read type (%%type reader) (... ...))
|
||
(switch/compile-time-keys
|
||
type
|
||
(%%type (%read %%type reader))
|
||
(... ...)
|
||
(else
|
||
(let ((offset (align offset (alignof type))))
|
||
(values (%read-c-struct bv offset type)
|
||
(+ offset (sizeof type)))))))
|
||
(dispatch-read
|
||
type
|
||
(int8 bytevector-s8-ref)
|
||
(uint8 bytevector-u8-ref)
|
||
(int16 bytevector-s16-native-ref)
|
||
(uint16 bytevector-u16-native-ref)
|
||
(int32 bytevector-s32-native-ref)
|
||
(uint32 bytevector-u32-native-ref)
|
||
(int64 bytevector-s64-native-ref)
|
||
(uint64 bytevector-u64-native-ref)
|
||
(float bytevector-ieee-single-native-ref)
|
||
(double bytevector-ieee-double-native-ref)
|
||
(complex-float bytevector-complex-single-native-ref)
|
||
(complex-double bytevector-complex-double-native-ref)
|
||
('* bytevector-pointer-ref))))
|
||
|
||
(define-syntax-rule (read-c-struct %bv %offset ((field type) ...) k)
|
||
(let ((bv %bv)
|
||
(offset %offset)
|
||
(size (compile-time-eval (sizeof (list 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)
|
||
(offset %offset)
|
||
(type %type)
|
||
(value %value))
|
||
(define-syntax-rule (%write type writer)
|
||
(let ((offset (align offset (compile-time-eval (alignof type)))))
|
||
(writer bv offset value)
|
||
(+ offset (compile-time-eval (sizeof type)))))
|
||
(define-syntax-rule (dispatch-write type (%%type writer) (... ...))
|
||
(switch/compile-time-keys
|
||
type
|
||
(%%type (%write %%type writer))
|
||
(... ...)
|
||
(else
|
||
(let ((offset (align offset (alignof type))))
|
||
(%write-c-struct bv offset type value)
|
||
(+ offset (sizeof type))))))
|
||
(dispatch-write
|
||
type
|
||
(int8 bytevector-s8-set!)
|
||
(uint8 bytevector-u8-set!)
|
||
(int16 bytevector-s16-native-set!)
|
||
(uint16 bytevector-u16-native-set!)
|
||
(int32 bytevector-s32-native-set!)
|
||
(uint32 bytevector-u32-native-set!)
|
||
(int64 bytevector-s64-native-set!)
|
||
(uint64 bytevector-u64-native-set!)
|
||
(float bytevector-ieee-single-native-set!)
|
||
(double bytevector-ieee-double-native-set!)
|
||
(complex-float bytevector-complex-single-native-set!)
|
||
(complex-double bytevector-complex-double-native-set!)
|
||
('* bytevector-pointer-set!))))
|
||
|
||
(define-syntax-rule (write-c-struct %bv %offset ((field type) ...))
|
||
(let ((bv %bv)
|
||
(offset %offset)
|
||
(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-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
|
||
(() #t)
|
||
(_ (error "too many values" vals))))
|
||
((type . types)
|
||
(match vals
|
||
((val . vals)
|
||
(lp (write-field bv offset type val) types vals))
|
||
(() (error "too few values" vals)))))))
|
||
|
||
;; 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
|
||
(() '())
|
||
((type . types)
|
||
(call-with-values (lambda () (read-field bv offset type))
|
||
(lambda (val offset)
|
||
(cons val (lp offset types))))))))
|
||
|
||
(define (make-c-struct types vals)
|
||
(let ((bv (make-bytevector (sizeof types) 0)))
|
||
(%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))
|
||
|
||
|
||
;;;
|
||
;;; Wrapped pointer types.
|
||
;;;
|
||
|
||
(define-syntax define-wrapped-pointer-type
|
||
(lambda (stx)
|
||
"Define helper procedures to wrap pointer objects into Scheme
|
||
objects with a disjoint type. Specifically, this macro defines PRED, a
|
||
predicate for the new Scheme type, WRAP, a procedure that takes a
|
||
pointer object and returns an object that satisfies PRED, and UNWRAP
|
||
which does the reverse. PRINT must name a user-defined object printer."
|
||
(syntax-case stx ()
|
||
((_ type-name pred wrap unwrap print)
|
||
(with-syntax ((%wrap (datum->syntax #'wrap (gensym "wrap"))))
|
||
#'(begin
|
||
(define-record-type type-name
|
||
(%wrap pointer)
|
||
pred
|
||
(pointer unwrap))
|
||
(define wrap
|
||
;; Use a weak hash table to preserve pointer identity, i.e.,
|
||
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
|
||
(let ((ptr->obj (make-weak-value-hash-table 3000)))
|
||
(lambda (ptr)
|
||
(or (hash-ref ptr->obj ptr)
|
||
(let ((o (%wrap ptr)))
|
||
(hash-set! ptr->obj ptr o)
|
||
o)))))
|
||
(set-record-type-printer! type-name print)))))))
|