├── .github ├── FUNDING.yml └── workflows │ └── ci.yml ├── .gitignore ├── src ├── pffi │ ├── bv-pointer.capy.sls │ ├── global.chezscheme.sls │ ├── bv-pointer.nmosh.sls │ ├── bv-pointer.mosh.sls │ ├── misc.sls │ ├── bv-pointer.chezscheme.sls │ ├── variable │ │ ├── helper.sls │ │ └── helper.chezscheme.sls │ ├── misc.chezscheme.sls │ ├── pointers.sls │ ├── procedure.sls │ ├── variable.sls │ ├── struct │ │ ├── chez.sls │ │ └── helper.sls │ ├── ffi-type-descriptor.sls │ ├── helper.chezscheme.sls │ ├── struct.chezscheme.sls │ ├── compat.sagittarius.sls │ ├── compat.mosh.sls │ ├── compat.vicare.sls │ ├── compat.chezscheme.sls │ ├── compat.guile.sls │ ├── compat.capy.sls │ └── compat.larceny.sls └── pffi.sls ├── examples ├── struct.c ├── variable.c ├── callback.c ├── struct.scm ├── callback.scm ├── variable.scm └── Makefile ├── .travis.yml ├── ReleaseNotes.md ├── ci-test.sh ├── tests ├── lib │ ├── LICENSE │ └── srfi │ │ └── %3a64.chezscheme.sls ├── test-struct.scm ├── chez.test.scm ├── functions.c └── test.scm ├── Makefile └── README.md /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: ktakashi 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.so 2 | *.log 3 | tests/functions 4 | tests/lib/srfi/:64 5 | tests/lib/srfi/:64.sls -------------------------------------------------------------------------------- /src/pffi/bv-pointer.capy.sls: -------------------------------------------------------------------------------- 1 | (library (pffi bv-pointer) 2 | (export bytevector->pointer) 3 | (import (core foreign))) -------------------------------------------------------------------------------- /examples/struct.c: -------------------------------------------------------------------------------- 1 | struct st1 2 | { 3 | int count; 4 | void *elements; 5 | }; 6 | 7 | struct st2 8 | { 9 | struct st1 p; 10 | short attr; 11 | }; 12 | 13 | static int values[] = {0,1,2,3,4,5,6,7,8,9}; 14 | 15 | #define CONST 1L 16 | #define INT_ARRAY 1L<<1; 17 | 18 | void fill_struct(struct st2 *s) 19 | { 20 | s->p.count = sizeof(values)/sizeof(values[0]); 21 | s->p.elements = (void *)values; 22 | s->attr = CONST | INT_ARRAY; 23 | } 24 | 25 | /* gcc -fPIC -o struct.so -shared struct.c */ 26 | -------------------------------------------------------------------------------- /examples/variable.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int global_int = 10; 4 | char *global_string = NULL; 5 | 6 | int get_global_int() 7 | { 8 | return global_int; 9 | } 10 | 11 | void init_global_string() 12 | { 13 | static const char hello[] = "hello"; 14 | int i; 15 | size_t len = sizeof(hello)/sizeof(hello[0]); 16 | 17 | global_string = (char *)malloc(len + 1); 18 | for (i = 0; i < len; i++) { 19 | global_string[i] = hello[i]; 20 | } 21 | global_string[i] = '\0'; 22 | } 23 | 24 | char * get_global_string() 25 | { 26 | return global_string; 27 | } 28 | 29 | 30 | /* gcc -fPIC -shared -o variable.so variable.c */ 31 | -------------------------------------------------------------------------------- /examples/callback.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | /* From Chez Scheme Version 8 User's Guide */ 5 | 6 | typedef void (*CB)(char); 7 | 8 | CB callbacks[256]; 9 | 10 | void cb_init(void) { 11 | int i; 12 | 13 | for (i = 0; i < 256; i += 1) 14 | callbacks[i] = (CB)0; 15 | } 16 | 17 | /* modified to intptr_t to shut compiler up */ 18 | void register_callback(char c, intptr_t cb) { 19 | callbacks[c] = (CB)cb; 20 | } 21 | 22 | void event_loop(void) { 23 | CB f; char c; 24 | 25 | for (;;) { 26 | c = getchar(); 27 | if (c == EOF) break; 28 | f = callbacks[c]; 29 | if (f != (CB)0) f(c); 30 | } 31 | } 32 | 33 | /* gcc -shared -fPIC -o callback.so callback.c */ 34 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | dist: trusty 3 | branches: 4 | only: 5 | - master 6 | 7 | services: mongodb 8 | addons: 9 | apt: 10 | update: true 11 | packages: 12 | - cmake 13 | - gcc 14 | - g++ 15 | - make 16 | - libgc-dev 17 | - zlib1g-dev 18 | - libffi-dev 19 | - libssl-dev 20 | - libncurses5-dev 21 | - curl 22 | 23 | before_install: 24 | - curl https://raw.githubusercontent.com/ktakashi/scheme-env/master/bin/install.sh | bash 25 | - export PATH=$PATH:~/.scheme-env/bin 26 | 27 | install: 28 | - scheme-env install sagittarius@0.9.2 29 | - scheme-env install chez@v9.5 30 | - scheme-env install larceny@1.3 31 | - find ~/.scheme-env/implementations -maxdepth 3 -type d -exec ls -l {} + 32 | 33 | script: 34 | - ./ci-test.sh 35 | -------------------------------------------------------------------------------- /examples/struct.scm: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import (rnrs) (pffi)) 3 | 4 | (define libstruct 5 | (open-shared-object "struct.so")) 6 | (define (print . args) 7 | (for-each display args) (newline) 8 | (flush-output-port (current-output-port))) 9 | 10 | (define fill-struct (foreign-procedure libstruct void fill_struct (pointer))) 11 | 12 | (define-foreign-struct st1 13 | (fields (int count) 14 | (pointer elements))) 15 | (define-foreign-struct st2 16 | (fields (st1 p) 17 | (short attr))) 18 | (define-foreign-struct st2* 19 | (fields (short attr)) 20 | (parent st1)) 21 | 22 | (let ((st (make-st2 (make-st1 0 (integer->pointer 0)) 0)) 23 | (st* (make-st2* 0 (integer->pointer 0) 0))) 24 | (fill-struct (bytevector->pointer st)) 25 | (fill-struct (bytevector->pointer st*)) 26 | (print (st1-count st)) 27 | (print st) 28 | (print (st2-p st)) 29 | (print (st1-count (st2-p st))) 30 | (print (st1-count st*))) 31 | 32 | -------------------------------------------------------------------------------- /ReleaseNotes.md: -------------------------------------------------------------------------------- 1 | ### version x.x.x (future release) 2 | 3 | **New implementation** 4 | 5 | - Capy Scheme is supported (thanks to @playX18) 6 | 7 | **Improvements** 8 | 9 | - Better `wchar_t` handling on Sagittarius 0.9.3 or later 10 | - Removing overriding system object on Guile (thanks to @zadoz03) 11 | 12 | ### version 25.05.16 13 | 14 | **Breaking changes** 15 | 16 | - Using ftype for `define-foreign-struct` and `define-foreign-union` on Chez 17 | This means, `alignment` keyword doesn't work on Chez. 18 | - Introducing `struct` keyword on struct member to distinguish primitive 19 | and struct. 20 | - Foreign types are now wrapped or ftype (on Chez), instead of symbols. 21 | 22 | **New features** 23 | 24 | - `define-type-alias` is introduced, similar usage as `typedef` in C. 25 | - `boolean` support for Scheme boolean. 26 | - Supporting array foreign variable. 27 | - Supporting `(* type)` pointer form for foreign variable. 28 | - Empty struct, i.e. `(define-foreign-struct foo)`, is supported 29 | - Supporting `wchar_t` as Scheme character. 30 | -------------------------------------------------------------------------------- /examples/callback.scm: -------------------------------------------------------------------------------- 1 | (import (rnrs) (pffi)) 2 | 3 | (define libcallback 4 | (open-shared-object "callback.so")) 5 | 6 | (define cb-init 7 | (foreign-procedure libcallback void cb_init ())) 8 | (define register-callback 9 | (foreign-procedure libcallback void register_callback 10 | (char (callback void (char))))) 11 | (define event-loop 12 | (foreign-procedure libcallback void event_loop ())) 13 | 14 | (define ouch 15 | (c-callback void ((char c)) 16 | (lambda (c) 17 | (display "Ouch! Hit by '") 18 | (display c) (display "'") (newline) 19 | (flush-output-port (current-output-port))))) 20 | (define rats 21 | (c-callback void ((char c)) 22 | (lambda (c) 23 | (display "Rats! Received '") 24 | (display c) (display "'") (newline) 25 | (flush-output-port (current-output-port))))) 26 | 27 | (cb-init) 28 | (register-callback (char->integer #\a) ouch) 29 | (register-callback (char->integer #\c) rats) 30 | (register-callback (char->integer #\e) ouch) 31 | 32 | (display "start loop") (newline) 33 | (flush-output-port (current-output-port)) 34 | 35 | (event-loop) 36 | -------------------------------------------------------------------------------- /examples/variable.scm: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import (rnrs) (pffi)) 3 | 4 | (define lib (open-shared-object "variable.so")) 5 | 6 | (define (print . args) 7 | (for-each display args) (newline) 8 | (flush-output-port (current-output-port))) 9 | 10 | (define-foreign-variable lib int global_int) 11 | 12 | (print global-int) 13 | (set! global-int (+ global-int 1)) 14 | (print global-int) 15 | (print ((foreign-procedure lib int get_global_int ()))) 16 | 17 | ;; string 18 | ((foreign-procedure lib void init_global_string ())) 19 | (define-foreign-variable lib pointer global_string) 20 | 21 | 22 | (print global-string) ;; pointer 23 | 24 | (define (null-terminate-pointer->string p) 25 | (let loop ((i 0) (l '())) 26 | (let ((c (pointer-ref-c-uint8 p i))) 27 | (if (zero? c) 28 | (list->string (reverse l)) 29 | (loop (+ i 1) (cons (integer->char c) l)))))) 30 | 31 | (print (null-terminate-pointer->string global-string)) 32 | 33 | (pointer-set-c-uint8! global-string 0 (char->integer #\H)) 34 | (print (null-terminate-pointer->string global-string)) 35 | (print (null-terminate-pointer->string 36 | ((foreign-procedure lib pointer get_global_string ())))) 37 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: R6RS Portable FFI 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | branches: 9 | - master 10 | 11 | jobs: 12 | Scheme-env-build: 13 | runs-on: ubuntu-latest 14 | steps: 15 | - name: Checkout 16 | uses: actions/checkout@v2 17 | with: 18 | path: target 19 | - name: Install dependencies 20 | run: | 21 | sudo apt-get update 22 | sudo apt-get -y install libgc-dev zlib1g-dev libffi-dev curl libx11-dev 23 | - name: Install scheme-env 24 | run: | 25 | curl https://raw.githubusercontent.com/ktakashi/scheme-env/master/bin/install.sh | bash 26 | echo "$HOME/.scheme-env/bin" >> $GITHUB_PATH 27 | - name: Install Implementations 28 | run: | 29 | scheme-env install sagittarius 30 | scheme-env install chez 31 | - name: Run test 32 | working-directory: target 33 | run: ./ci-test.sh 34 | 35 | Makefile-build: 36 | runs-on: ubuntu-latest 37 | steps: 38 | - name: Checkout 39 | uses: actions/checkout@v2 40 | with: 41 | path: target 42 | - name: Install Implentations 43 | run: | 44 | sudo apt update 45 | sudo apt -y install guile-3.0 racket 46 | - name: Run test 47 | working-directory: target 48 | run: make guile racket 49 | -------------------------------------------------------------------------------- /ci-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | declare -a implementations=($(scheme-env list -l)) 4 | 5 | echo "Preparing for Chez Scheme" 6 | create_symlink() { 7 | flag=$1 8 | target=$2 9 | src=$3 10 | if [ ! ${flag} ${src} ]; then 11 | ln -s ${target} ${src} 12 | fi 13 | } 14 | create_symlink -f %3a64.chezscheme.sls tests/lib/srfi/:64.sls 15 | create_symlink -d %3a64 tests/lib/srfi/:64 16 | 17 | check_output() { 18 | local status=0 19 | while IFS= read -r LINE; do 20 | echo $LINE 21 | case $LINE in 22 | *FAIL*) status=255 ;; 23 | *Exception*) status=255 ;; 24 | esac 25 | done 26 | return ${status} 27 | } 28 | 29 | EXIT_STATUS=0 30 | 31 | echo "Preparing for tests" 32 | 33 | gcc -fPIC -shared -Wall -o tests/functions.so tests/functions.c 34 | 35 | cd tests 36 | for impl in ${implementations[@]}; do 37 | echo Testing with ${impl} 38 | name=${impl%@*} 39 | for file in *.scm; do 40 | case $file in 41 | $name.test.scm) 42 | scheme-env run ${impl} \ 43 | --loadpath ../src \ 44 | --loadpath lib \ 45 | --standard r6rs --program ${file} | check_output 46 | ;; 47 | test.scm) 48 | scheme-env run ${impl} \ 49 | --loadpath ../src \ 50 | --loadpath lib \ 51 | --standard r6rs --program ${file} | check_output 52 | ;; 53 | *) 54 | # Do nothing 55 | ;; 56 | esac 57 | case ${EXIT_STATUS} in 58 | 0) EXIT_STATUS=$? ;; 59 | esac 60 | done 61 | echo Done! 62 | echo 63 | done 64 | cd .. 65 | 66 | echo Library test status ${EXIT_STATUS} 67 | exit ${EXIT_STATUS} 68 | -------------------------------------------------------------------------------- /tests/lib/LICENSE: -------------------------------------------------------------------------------- 1 | The following license applies to srfi/%3a64/testing.chezscheme.sls and 2 | srfi/%3a64.sls under this directory. 3 | 4 | =========================================================================== 5 | Copyright (c) 2008-2009 Derick Eddington 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a 8 | copy of this software and associated documentation files (the "Software"), 9 | to deal in the Software without restriction, including without limitation 10 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | and/or sell copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | Except as contained in this notice, the name(s) of the above copyright 18 | holders shall not be used in advertising or otherwise to promote the sale, 19 | use or other dealings in this Software without prior written authorization. 20 | 21 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 24 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | DEALINGS IN THE SOFTWARE. 28 | =========================================================================== 29 | -------------------------------------------------------------------------------- /src/pffi/global.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/global.chezscheme.sls - Global storage for Chez Scheme 4 | ;;; 5 | ;;; Copyright (c) 2022 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; ugly solution, please FIXME 32 | #!r6rs 33 | (library (pffi global) 34 | (export *typedef-table*) 35 | (import (rnrs)) 36 | (define *typedef-table* (make-eq-hashtable))) 37 | -------------------------------------------------------------------------------- /tests/test-struct.scm: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import (rnrs) 3 | (pffi) 4 | (srfi :64)) 5 | 6 | (test-begin "PFFI struct alignment") 7 | 8 | ;; alignment 9 | (define (?p p8 p4) 10 | (if (= size-of-pointer 8) 11 | p8 12 | p4)) 13 | 14 | 15 | (let () 16 | (define-foreign-struct packed 17 | (fields (char c) (short s) (pointer p)) 18 | (alignment 4)) 19 | 20 | (define-foreign-struct non-packed 21 | (fields (char c) (short s) (pointer p))) 22 | 23 | (define-foreign-struct mixed 24 | (fields ((struct packed) p) ((struct non-packed) np))) 25 | 26 | (define-foreign-struct mixed-packed 27 | (fields ((struct packed) p) ((struct non-packed) np)) 28 | (alignment 4)) 29 | 30 | (test-equal "size-of-packed" (?p 12 8) size-of-packed) 31 | (test-equal "size-of-non-packed" (?p 16 8) size-of-non-packed) 32 | (test-equal "size-of-mixed" (?p 32 16) size-of-mixed) 33 | (test-equal "size-of-mixed-packed" (?p 28 16) size-of-mixed-packed) 34 | 35 | (let ((p (make-packed 20 1 (integer->pointer 2))) 36 | (np (make-non-packed 20 1 (integer->pointer 2)))) 37 | (test-equal "packed instance" size-of-packed (bytevector-length p)) 38 | (test-equal "packed-c" 20 (packed-c p)) 39 | (test-equal "packed-s" 1 (packed-s p)) 40 | (test-equal "packed-p" 2 (pointer->integer (packed-p p))) 41 | 42 | (let ((m (make-mixed p np))) 43 | (test-equal "mixed instance" size-of-mixed (bytevector-length m)) 44 | (test-equal "mixed-p" p (mixed-p m)) 45 | (test-equal "mixed-np" np (mixed-np m))) 46 | 47 | (let ((m (make-mixed-packed p np))) 48 | (test-equal "mixed-packed instance" size-of-mixed-packed (bytevector-length m)) 49 | (test-equal "mixed-packed-p" p (mixed-packed-p m)) 50 | (test-equal "mixed-packed-np" np (mixed-packed-np m))))) 51 | 52 | ;; For guile... 53 | (define failed (test-runner-fail-count (test-runner-current))) 54 | (test-end) 55 | 56 | (exit failed) 57 | -------------------------------------------------------------------------------- /src/pffi/bv-pointer.nmosh.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/bv-pointer.nmosh.sls - Compatible layer of compatible layer 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | ;; kinda silly but seems there is no way to get 33 | ;; bytevector-pointer from Mosh but NMosh 34 | (library (pffi bv-pointer) 35 | (export (rename (bytevector-pointer bytevector->pointer))) 36 | (import (primitives bytevector-pointer))) 37 | -------------------------------------------------------------------------------- /src/pffi/bv-pointer.mosh.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/bv-pointer.nmosh.sls - Compatible layer of compatible layer 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | 33 | ;; for Psyntax Mosh, we just raise an error, sorry 34 | (library (pffi bv-pointer) 35 | (export bytevector->pointer) 36 | (import (rnrs) (psyntax system $bootstrap)) 37 | 38 | ;; seems we can get it like this 39 | (define bytevector->pointer (eval-core 'bytevector-pointer)) 40 | ) 41 | -------------------------------------------------------------------------------- /tests/chez.test.scm: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import (rnrs) 3 | (pffi) 4 | (srfi :64) 5 | (rename (pffi bv-pointer) 6 | (bytevector->pointer bytevector->address)) 7 | (only (pffi compat) pointer-tracker) 8 | (only (chezscheme) collect locked-object? 9 | make-weak-eq-hashtable)) 10 | 11 | (define *pointer-table* (make-weak-eq-hashtable)) 12 | (define (pointer-statistic) (hashtable-size *pointer-table*)) 13 | 14 | ;; Set the tracker to count pointer allocations. 15 | (pointer-tracker (lambda (bv p) (hashtable-set! *pointer-table* p bv))) 16 | 17 | (test-begin "PFFI Chez specific") 18 | 19 | (define test-lib (open-shared-object "./functions.so")) 20 | (define fill-one (foreign-procedure test-lib void fill_one (pointer int))) 21 | (define fill-n (foreign-procedure test-lib void fill_n 22 | (pointer int (callback int (int))))) 23 | 24 | (define (allocate-alot n) 25 | (do ((i 0 (+ i 1)) 26 | (bv (make-bytevector n) (make-bytevector (bytevector-length bv)))) 27 | ((= i 100000)) 28 | (bytevector-u8-set! bv (mod i n) (mod i 255)))) 29 | 30 | (let* ((bv (make-bytevector (* 4 5) 0)) 31 | (ptr (bytevector->pointer bv))) 32 | (test-assert (locked-object? bv)) 33 | (fill-one ptr 1) 34 | (test-equal '(1 0 0 0 0) (bytevector->uint-list bv (native-endianness) 4)) 35 | (collect) 36 | (fill-one ptr 2) 37 | (test-equal '(1 1 0 0 0) (bytevector->uint-list bv (native-endianness) 4))) 38 | 39 | (let* ((callback (c-callback int ((int i)) (lambda (i) (collect) i))) 40 | (bv (make-bytevector (* 4 5) 0)) 41 | (ptr (bytevector->pointer bv))) 42 | (fill-n ptr 2 callback) 43 | (test-equal '(1 2 0 0 0) (bytevector->uint-list bv (native-endianness) 4)) 44 | (free-c-callback callback)) 45 | 46 | ;; make sure the locked pointers are gone 47 | (allocate-alot 1000) 48 | (collect) 49 | (test-assert (< (pointer-statistic) 2)) 50 | 51 | (let ((sum (foreign-procedure test-lib (__collect_safe) int sum (int ___)))) 52 | (test-equal "variadic argument" 10 (sum 4 1 2 3 4))) 53 | 54 | 55 | (test-end) 56 | 57 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | LONG_BIT=$(shell getconf LONG_BIT) 2 | CFLAGS_32= 3 | CFLAGS_64=-fPIC 4 | CFLAGS=$(CFLAGS_$(LONG_BIT)) 5 | 6 | LDPATH=$(LD_LIBRARY_PATH) 7 | 8 | prepare: 9 | gcc $(CFLAGS) -shared -o callback.so callback.c 10 | gcc $(CFLAGS) -shared -o struct.so struct.c 11 | gcc $(CFLAGS) -shared -o variable.so variable.c 12 | 13 | # Sagittarius and Vicare read shared object from LD_LIBRARY_PATH 14 | sagittarius: prepare 15 | LD_LIBRARY_PATH=$(LDPATH):tests; sagittarius -L ../src struct.scm 16 | LD_LIBRARY_PATH=$(LDPATH):tests; sagittarius -L ../src variable.scm 17 | LD_LIBRARY_PATH=$(LDPATH):tests; sagittarius -L ../src callback.scm 18 | 19 | vicare: prepare 20 | LD_LIBRARY_PATH=$(LDPATH):tests; vicare -L ../src struct.scm 21 | LD_LIBRARY_PATH=$(LDPATH):tests; vicare -L ../src variable.scm 22 | LD_LIBRARY_PATH=$(LDPATH):tests; vicare -L ../src callback.scm 23 | 24 | # Seems Mosh as well 25 | mosh: prepare 26 | LD_LIBRARY_PATH=$(LDPATH):tests; nmosh --loadpath=../src struct.scm 27 | LD_LIBRARY_PATH=$(LDPATH):tests; nmosh --loadpath=../src variable.scm 28 | LD_LIBRARY_PATH=$(LDPATH):tests; nmosh --loadpath=../src callback.scm 29 | 30 | racket: prepare 31 | LD_LIBRARY_PATH=$(LDPATH):tests; plt-r6rs ++path ../src struct.scm 32 | LD_LIBRARY_PATH=$(LDPATH):tests; plt-r6rs ++path ../src variable.scm 33 | LD_LIBRARY_PATH=$(LDPATH):tests; plt-r6rs ++path ../src callback.scm 34 | 35 | 36 | # guile doesn't read .sls or .guile.sls by default... 37 | prepare-guile: 38 | echo \(set! %load-extensions \'\(\".guile.sls\" \".sls\" \".scm\"\)\) > .guile.rc 39 | 40 | guile: prepare prepare-guile 41 | LD_LIBRARY_PATH=$(LDPATH):tests; guile --no-auto-compile -l .guile.rc -L ../src struct.scm 42 | LD_LIBRARY_PATH=$(LDPATH):tests; guile --no-auto-compile -l .guile.rc -L ../src variable.scm 43 | LD_LIBRARY_PATH=$(LDPATH):tests; guile --no-auto-compile -l .guile.rc -L ../src callback.scm 44 | rm .guile.rc 45 | 46 | capy: prepare 47 | LD_LIBRARY_PATH=.:tests; capy -log:info -L ../src struct.scm 48 | LD_LIBRARY_PATH=.:tests; capy -log:info -L ../src variable.scm 49 | -------------------------------------------------------------------------------- /src/pffi/misc.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/misc.sls - Misc 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (library (pffi misc) 32 | (export string-map take drop split-at drop-right 33 | define-type-alias) 34 | (import (only (rnrs) define-syntax syntax-rules define *) 35 | (only (srfi :13) string-map) 36 | (only (srfi :1) take drop drop-right split-at) 37 | (only (pffi compat) pointer callback)) 38 | 39 | (define-syntax define-type-alias 40 | (syntax-rules (* callback) 41 | ((_ name (* alias)) (define name pointer)) 42 | ((_ name alias) (define name alias)))) 43 | 44 | ) 45 | -------------------------------------------------------------------------------- /tests/lib/srfi/%3a64.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :64) 4 | (export 5 | test-apply 6 | test-approximate 7 | test-assert 8 | test-begin 9 | test-end 10 | test-eq 11 | test-equal 12 | test-eqv 13 | test-error 14 | test-expect-fail 15 | test-group 16 | test-group-with-cleanup 17 | test-log-to-file 18 | test-match-all 19 | test-match-any 20 | test-match-name 21 | test-match-nth 22 | test-on-bad-count-simple 23 | test-on-bad-end-name-simple 24 | test-on-final-simple 25 | test-on-group-begin-simple 26 | test-on-group-end-simple 27 | test-on-test-end-simple 28 | test-passed? 29 | test-read-eval-string 30 | test-result-alist 31 | test-result-alist! 32 | test-result-clear 33 | test-result-kind 34 | test-result-ref 35 | test-result-remove 36 | test-result-set! 37 | test-runner-aux-value 38 | test-runner-aux-value! 39 | test-runner-create 40 | test-runner-current 41 | test-runner-factory 42 | test-runner-fail-count 43 | test-runner-fail-count! 44 | test-runner-get 45 | test-runner-group-path 46 | test-runner-group-stack 47 | test-runner-group-stack! 48 | test-runner-null 49 | test-runner-on-bad-count 50 | test-runner-on-bad-count! 51 | test-runner-on-bad-end-name 52 | test-runner-on-bad-end-name! 53 | test-runner-on-final 54 | test-runner-on-final! 55 | test-runner-on-group-begin 56 | test-runner-on-group-begin! 57 | test-runner-on-group-end 58 | test-runner-on-group-end! 59 | test-runner-on-test-begin 60 | test-runner-on-test-begin! 61 | test-runner-on-test-end 62 | test-runner-on-test-end! 63 | test-runner-pass-count 64 | test-runner-pass-count! 65 | test-runner-reset 66 | test-runner-simple 67 | test-runner-skip-count 68 | test-runner-skip-count! 69 | test-runner-test-name 70 | test-runner-xfail-count 71 | test-runner-xfail-count! 72 | test-runner-xpass-count 73 | test-runner-xpass-count! 74 | test-runner? 75 | test-skip 76 | test-with-runner) 77 | (import (srfi :64 testing)) 78 | ) 79 | -------------------------------------------------------------------------------- /src/pffi/bv-pointer.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/bv-pointer.chezscheme.sls - Compatible layer of compatible layer 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | (library (pffi bv-pointer) 33 | (export (rename (object->reference-address bytevector->pointer))) 34 | (import (rnrs) 35 | (only (chezscheme) 36 | object->reference-address 37 | ;; machine-type foreign-procedure load-shared-object 38 | )) 39 | 40 | ;; (define dummy 41 | ;; (case (machine-type) 42 | ;; ((ta6le a6le i3le ti3le arm32le arm64le tarm64le ppc32le) (load-shared-object "libc.so.6")) 43 | ;; ((i3osx ti3osx a6osx ta6osx arm64osx tarm64osx) (load-shared-object "libc.dylib")) 44 | ;; ((ta6nt a6nt i3nt ti3nt) (load-shared-object "msvcrt.dll")) 45 | ;; (else (load-shared-object "libc.so")))) 46 | 47 | ;; (define f (foreign-procedure "memmove" (u8* u8* size_t) uptr)) 48 | ;; (define (bytevector->pointer bv) (f bv bv 0)) 49 | ) 50 | -------------------------------------------------------------------------------- /src/pffi/variable/helper.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/variable/helper.sls - Foreign varialbe helper 4 | ;;; 5 | ;;; Copyright (c) 2015-2025 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | #!r6rs 31 | (library (pffi variable helper) 32 | (export type->pointer-ref 33 | type->pointer-set! 34 | type->size-of) 35 | (import (rnrs) 36 | (pffi ffi-type-descriptor)) 37 | (define (type->pointer-ref type) 38 | (unless (pointer-accesible-ffi-type-descriptor? type) 39 | (let ((name (ffi-type-descriptor-name type))) 40 | (assertion-violation 'define-foreign-variable 41 | (string-append (symbol->string name) " is not supported") type))) 42 | (pointer-accesible-ffi-type-descriptor-pointer-ref type)) 43 | 44 | (define (type->pointer-set! type) 45 | (unless (pointer-accesible-ffi-type-descriptor? type) 46 | (let ((name (ffi-type-descriptor-name type))) 47 | (assertion-violation 'define-foreign-variable 48 | (string-append (symbol->string name) " is not supported") type))) 49 | (pointer-accesible-ffi-type-descriptor-pointer-set! type)) 50 | 51 | (define (type->size-of type) (ffi-type-descriptor-size type)) 52 | ) 53 | -------------------------------------------------------------------------------- /src/pffi/misc.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/misc.sls - Misc for Chez Scheme 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | (library (pffi misc) 32 | (export string-map take drop split-at drop-right define-type-alias) 33 | (import (rnrs) 34 | (pffi helper) 35 | (only (chezscheme) reverse!)) 36 | ;; this is good enough 37 | (define (string-map proc s) (list->string (map proc (string->list s)))) 38 | 39 | (define (take lis k) 40 | (let recur ((lis lis) (k k)) 41 | (if (zero? k) '() 42 | (cons (car lis) 43 | (recur (cdr lis) (- k 1)))))) 44 | 45 | (define (drop lis k) 46 | (let iter ((lis lis) (k k)) 47 | (if (zero? k) lis (iter (cdr lis) (- k 1))))) 48 | 49 | (define (drop-right lis k) 50 | (or (integer? k) 51 | (assertion-violation 'drop-right "integer required for k" k)) 52 | (let recur ((lag lis) (lead (drop lis k))) 53 | (if (pair? lead) 54 | (cons (car lag) (recur (cdr lag) (cdr lead))) 55 | '()))) 56 | 57 | (define (split-at x k) 58 | (let recur ((lis x) (k k) (r '())) 59 | (cond ((zero? k) (values (reverse! r) lis)) 60 | ((null? lis) (error 'split-at "given list it too short")) 61 | (else (recur (cdr lis) (- k 1) (cons (car lis) r)))))) 62 | ) 63 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | LDPATH=$(LD_LIBRARY_PATH) 2 | LONG_BIT=$(shell getconf LONG_BIT) 3 | CFLAGS_32= 4 | CFLAGS_64=-fPIC 5 | CFLAGS=$(CFLAGS_$(LONG_BIT)) 6 | 7 | CHEZ?=scheme 8 | RACKET?=plt-r6rs 9 | GUILE?=guile 10 | SAGITTARIUS?=sagittarius 11 | 12 | all: 13 | @echo 'usage: make $traget' 14 | @echo ' sagittarius' 15 | @echo ' racket' 16 | @echo ' guile' 17 | @echo ' chez' 18 | 19 | prepare: 20 | cd tests; gcc $(CFLAGS) -shared -Wall -o functions.so functions.c 21 | 22 | test: sagittarius mosh vicare racket guile larceny 23 | @echo done! 24 | 25 | # Sagittarius and Vicare read shared object from LD_LIBRARY_PATH 26 | sagittarius: prepare 27 | cd tests; $(SAGITTARIUS) -L../src test.scm 28 | cd tests; $(SAGITTARIUS) -L../src test-struct.scm 29 | 30 | prepare-racket: 31 | # Not sure since when, but Racket requires either platform specific extension 32 | # e.g. dynlib, or no extension. 33 | cd tests; gcc $(CFLAGS) -shared -Wall -o functions functions.c 34 | # Don't they have oneshot library installation command? 35 | # raco pkg install -t file -n pffi/helper --pkgs --force pffi-helper.plt 36 | $(RACKET) --force --install src/pffi/ffi-type-descriptor.sls 37 | $(RACKET) --force --install src/pffi/compat.mzscheme.sls 38 | $(RACKET) --force --install src/pffi/misc.sls 39 | $(RACKET) --force --install src/pffi/procedure.sls 40 | $(RACKET) --force --install src/pffi/variable/helper.sls 41 | $(RACKET) --force --install src/pffi/variable.sls 42 | $(RACKET) --force --install src/pffi/pointers.sls 43 | $(RACKET) --force --install src/pffi/struct/helper.sls 44 | $(RACKET) --force --install src/pffi/struct.sls 45 | $(RACKET) --force --install src/pffi.sls 46 | 47 | racket: prepare prepare-racket 48 | cd tests; $(RACKET) test.scm 49 | cd tests; $(RACKET) test-struct.scm 50 | 51 | guile: prepare 52 | cd tests; $(GUILE) --no-auto-compile --r6rs -L ../src test.scm 53 | cd tests; $(GUILE) --no-auto-compile --r6rs -L ../src test-struct.scm 54 | 55 | prepare-chez: prepare 56 | $(shell test ! -f tests/lib/srfi/:64.sls && ln -s %3a64.chezscheme.sls tests/lib/srfi/:64.sls) 57 | $(shell test ! -d tests/lib/srfi/:64 && ln -s %3a64 tests/lib/srfi/:64) 58 | 59 | chez: prepare-chez 60 | cd tests; $(CHEZ) --libdirs ../src:lib --program test.scm 61 | cd tests; $(CHEZ) --libdirs ../src:lib --program chez.test.scm 62 | 63 | 64 | ### Unsupported implementatins, let's put them at the bottom 65 | vicare: prepare 66 | cd test; vicare -L ../src test.scm 67 | 68 | # Seems Mosh as well 69 | mosh: prepare 70 | cd tests; mosh --loadpath=../src test.scm 71 | cd tests; nmosh --loadpath=../src test.scm 72 | 73 | prepare-larceny: 74 | cd tests; gcc -m32 -shared -Wall -o functions.so functions.c 75 | 76 | # Larceny raises an error if PFFI.log is there... 77 | larceny: prepare-larceny 78 | rm -f PFFI.log 79 | cd tests; larceny -path ../src -r6rs -program test.scm 80 | -------------------------------------------------------------------------------- /tests/functions.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | /* 7 | test C functions. 8 | */ 9 | 10 | int plus(int a, int b) 11 | { 12 | return a+b; 13 | } 14 | 15 | int callback_proc(int (*f)(int), int n) 16 | { 17 | return f(n); 18 | } 19 | 20 | int callback_proc2(int (*f)(int *), int n) 21 | { 22 | return f(&n); 23 | } 24 | 25 | void* callback_proc3(void* (*f)(int *), int n) 26 | { 27 | return f(&n); 28 | } 29 | 30 | 31 | void* id_str(char *s) 32 | { 33 | return (void *)s; 34 | } 35 | 36 | extern int externed_variable; 37 | int externed_variable = 10; 38 | 39 | int get_externed_variable() 40 | { 41 | return externed_variable; 42 | } 43 | 44 | void fill_one(int *arr, int size) 45 | { 46 | int i; 47 | for (i = 0; i < size; i++) { 48 | arr[i] = 1; 49 | } 50 | } 51 | 52 | void fill_n(int *arr, int size, int (*f)(int)) 53 | { 54 | int i; 55 | for (i = 0; i < size; i++) { 56 | arr[i] = f(i + 1); 57 | } 58 | } 59 | 60 | 61 | int sum(int n, ...) 62 | { 63 | va_list l; 64 | int sum = 0; 65 | int x; 66 | 67 | va_start(l, n); 68 | 69 | for (x = 0; x < n; x++) { 70 | sum += va_arg(l, int); 71 | } 72 | 73 | va_end(l); 74 | return sum; 75 | 76 | } 77 | 78 | struct st1 79 | { 80 | int count; 81 | int *elements; 82 | }; 83 | struct st2 84 | { 85 | struct st1 p; 86 | short attr; 87 | }; 88 | 89 | 90 | void fill_st_values(struct st2 *st) 91 | { 92 | int i; 93 | st->p.count = 10; 94 | st->p.elements = (int *)malloc(sizeof(int) * 10); 95 | /* fprintf(stderr, "%p:%u\n", st->p.elements, offsetof(struct st1, elements)); */ 96 | for (i = 0; i < 10; i++) st->p.elements[i] = i; 97 | st->attr = 5; 98 | } 99 | 100 | void free_st_values(struct st2 *st) 101 | { 102 | free(st->p.elements); 103 | } 104 | 105 | /* for boolean test */ 106 | int is_even(int n) 107 | { 108 | return n % 2 == 0; 109 | } 110 | 111 | int is_odd(int n) 112 | { 113 | return n % 2 != 0; 114 | } 115 | 116 | int check_dispatch(int n, int check_even) 117 | { 118 | if (check_even) { 119 | return is_even(n); 120 | } else { 121 | return is_odd(n); 122 | } 123 | } 124 | 125 | extern int int_array[]; 126 | int int_array[10] = {1,2,3,4,5,6,7,8,9,10}; 127 | 128 | int * get_int_array() { 129 | return int_array; 130 | } 131 | 132 | extern int * int_pointer; 133 | static int int_value = 100; 134 | int * int_pointer = &int_value; 135 | 136 | int initial_int_pointer_value() 137 | { 138 | return int_value; 139 | } 140 | 141 | wchar_t wtoupper(wchar_t wc) 142 | { 143 | return towupper(wc); 144 | } 145 | 146 | wchar_t wcallback(wchar_t wc, wchar_t (* proc)(wchar_t)) 147 | { 148 | return proc(wc); 149 | } 150 | 151 | char * str_cb(char *st, char * (* cb)(char *)) 152 | { 153 | return cb(st); 154 | } 155 | 156 | wchar_t * wstr_cb(wchar_t *st, wchar_t * (* cb)(wchar_t *)) 157 | { 158 | return cb(st); 159 | } 160 | 161 | 162 | /* TODO more */ 163 | -------------------------------------------------------------------------------- /src/pffi/variable/helper.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/variable/helper.sls - Foreign varialbe helper 4 | ;;; 5 | ;;; Copyright (c) 2015-2025 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | #!r6rs 31 | (library (pffi variable helper) 32 | (export type->pointer-ref 33 | type->pointer-set! 34 | type->size-of) 35 | (import (rnrs) 36 | (only (chezscheme) foreign-ref foreign-set! ftype-sizeof) 37 | (pffi compat) 38 | (pffi helper) 39 | (pffi ffi-type-descriptor)) 40 | ;; maybe, we need to make pointer-ref generic... 41 | (define-syntax type->pointer-ref 42 | (lambda (x) 43 | (syntax-case x () 44 | ((_ type) 45 | (if (eq? (pffi-type->foreign-type (syntax->datum #'type)) 'void*) 46 | #'(lambda (ptr offset) 47 | (integer->pointer 48 | (foreign-ref (pffi-type->foreign-type 'type) 49 | (pointer->integer ptr) offset))) 50 | #'(lambda (ptr offset) 51 | (foreign-ref (pffi-type->foreign-type 'type) 52 | (pointer->integer ptr) offset))))))) 53 | 54 | (define-syntax type->pointer-set! 55 | (lambda (x) 56 | (syntax-case x () 57 | ((_ type) 58 | (if (eq? (pffi-type->foreign-type (syntax->datum #'type)) 'void*) 59 | #'(lambda (ptr offset value) 60 | (foreign-set! (pffi-type->foreign-type 'type) 61 | (pointer->integer ptr) 62 | offset (pointer->integer value))) 63 | #'(lambda (ptr offset value) 64 | (foreign-set! (pffi-type->foreign-type 'type) 65 | (pointer->integer ptr) offset value))))))) 66 | 67 | (define-syntax type->size-of (identifier-syntax ftype-sizeof)) 68 | 69 | ) 70 | -------------------------------------------------------------------------------- /src/pffi/pointers.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/pointers.sls - Pointer operations 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | 33 | (library (pffi pointers) 34 | (export pointer? 35 | null-pointer? 36 | bytevector->pointer 37 | pointer->bytevector 38 | pointer->integer 39 | integer->pointer 40 | ;; pointer ref 41 | pointer-ref-c-uint8 42 | pointer-ref-c-int8 43 | pointer-ref-c-uint16 44 | pointer-ref-c-int16 45 | pointer-ref-c-uint32 46 | pointer-ref-c-int32 47 | pointer-ref-c-uint64 48 | pointer-ref-c-int64 49 | pointer-ref-c-unsigned-char 50 | pointer-ref-c-char 51 | pointer-ref-c-unsigned-short 52 | pointer-ref-c-short 53 | pointer-ref-c-unsigned-int 54 | pointer-ref-c-int 55 | pointer-ref-c-unsigned-long 56 | pointer-ref-c-long 57 | pointer-ref-c-float 58 | pointer-ref-c-double 59 | pointer-ref-c-pointer 60 | pointer-ref-c-wchar 61 | 62 | ;; pointer set 63 | pointer-set-c-uint8! 64 | pointer-set-c-int8! 65 | pointer-set-c-uint16! 66 | pointer-set-c-int16! 67 | pointer-set-c-uint32! 68 | pointer-set-c-int32! 69 | pointer-set-c-uint64! 70 | pointer-set-c-int64! 71 | pointer-set-c-unsigned-char! 72 | pointer-set-c-char! 73 | pointer-set-c-unsigned-short! 74 | pointer-set-c-short! 75 | pointer-set-c-unsigned-int! 76 | pointer-set-c-int! 77 | pointer-set-c-unsigned-long! 78 | pointer-set-c-long! 79 | pointer-set-c-float! 80 | pointer-set-c-double! 81 | pointer-set-c-pointer! 82 | pointer-set-c-wchar!) 83 | (import (rnrs) 84 | (pffi compat)) 85 | 86 | (define (null-pointer? pointer) (zero? (pointer->integer pointer))) 87 | ) 88 | -------------------------------------------------------------------------------- /src/pffi/procedure.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/procedure.sls - FFI Procedure 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | (library (pffi procedure) 33 | (export foreign-procedure 34 | c-callback 35 | free-c-callback 36 | open-shared-object 37 | lookup-shared-object 38 | 39 | ;; primitive types 40 | ;; maybe these should be exported from 41 | ;; different library 42 | char unsigned-char 43 | short unsigned-short 44 | int unsigned-int 45 | long unsigned-long 46 | float double 47 | int8_t uint8_t 48 | int16_t uint16_t 49 | int32_t uint32_t 50 | int64_t uint64_t 51 | pointer callback 52 | void boolean wchar 53 | ___ 54 | 55 | size-of-char 56 | size-of-short 57 | size-of-int 58 | size-of-long 59 | size-of-float 60 | size-of-double 61 | size-of-pointer 62 | size-of-boolean 63 | size-of-int8_t 64 | size-of-int16_t 65 | size-of-int32_t 66 | size-of-int64_t 67 | size-of-wchar 68 | ) 69 | (import (rnrs) 70 | (pffi compat)) 71 | 72 | (define-syntax foreign-procedure 73 | (syntax-rules () 74 | ((_ lib (conv ...) ret name (args ...)) 75 | (make-c-function lib '(conv ...) ret 'name (list args ...))) 76 | ((_ lib ret name (args ...)) 77 | (make-c-function lib '() ret 'name (list args ...))))) 78 | 79 | (define-syntax c-callback 80 | (lambda (x) 81 | (syntax-case x (lambda) 82 | ((k ret ((type var) ...) (lambda (formals ...) body1 body ...)) 83 | (or (for-all bound-identifier=? #'(var ...) #'(formals ...)) 84 | (syntax-violation 'c-callback "invalid declaration" '#'x)) 85 | #'(k ret (type ...) (lambda (var ...) body1 body ...))) 86 | ((_ ret (args ...) proc) 87 | #'(make-c-callback ret (list args ...) proc))))) 88 | 89 | ) 90 | -------------------------------------------------------------------------------- /src/pffi/variable.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/variable.sls - Foreign variable 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | (library (pffi variable) 33 | (export define-foreign-variable define-type-alias array) 34 | (import (rnrs) 35 | (for (pffi misc) expand) 36 | (only (pffi misc) define-type-alias) 37 | (pffi compat) 38 | (pffi variable helper)) 39 | 40 | (define-syntax array (syntax-rules ())) 41 | 42 | ;; to make FFI variable settable, we use macro 43 | (define-syntax define-foreign-variable 44 | (lambda (x) 45 | (define (->scheme-name name) 46 | (string->symbol 47 | (string-map (lambda (c) (if (char=? c #\_) #\- c)) 48 | (string-downcase (symbol->string (syntax->datum name)))))) 49 | (syntax-case x (* array) 50 | ((k lib type name) 51 | (with-syntax ((scheme-name 52 | (datum->syntax #'k (->scheme-name #'name)))) 53 | #'(k lib type name scheme-name))) 54 | ((k lib (* type) name scheme-name) 55 | (identifier? #'type) 56 | #'(k lib pointer name scheme-name)) 57 | ((k lib type name scheme-name) 58 | (identifier? #'type) 59 | #'(begin 60 | (define pointer-ref (type->pointer-ref type)) 61 | (define pointer-set! (type->pointer-set! type)) 62 | (define dummy (lookup-shared-object lib (symbol->string 'name))) 63 | (define-syntax scheme-name 64 | (identifier-syntax 65 | (_ (pointer-ref dummy 0)) 66 | ((set! _ e) (pointer-set! dummy 0 e)))))) 67 | 68 | ((k lib (array type) name scheme-name) 69 | (identifier? #'type) 70 | #'(begin 71 | (define pointer-ref (type->pointer-ref type)) 72 | (define pointer-set! (type->pointer-set! type)) 73 | (define size-of (type->size-of type)) 74 | (define dummy (lookup-shared-object lib (symbol->string 'name))) 75 | (define-syntax scheme-name 76 | (make-variable-transformer 77 | (lambda (xx) 78 | (syntax-case xx (set!) 79 | ((set! scheme-name (n val)) 80 | #'(pointer-set! dummy (* size-of n) val)) 81 | ((_ n) #'(pointer-ref dummy (* size-of n))) 82 | (id (identifier? #'id) #'dummy)))))))))) 83 | ) 84 | -------------------------------------------------------------------------------- /src/pffi/struct/chez.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/struct/chez.sls - Chez specific helper 4 | ;;; 5 | ;;; Copyright (c) 2015-2025 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; Interact with Chez ftype, we need to have extra compat layer for Chez 32 | #!r6rs 33 | (library (pffi struct chez) 34 | (export process-accessors 35 | ->parent 36 | ;; funny that we need to export these 2... (meta -1) binding issue? 37 | ->value struct-field-address) 38 | (import (rnrs) 39 | (pffi compat) 40 | (pffi helper) 41 | (pffi struct helper) 42 | (only (chezscheme) 43 | make-ftype-pointer object->reference-address 44 | ftype-pointer-address 45 | ftype-ref ftype-set! ftype-sizeof 46 | ftype-&ref foreign-set! foreign-ref)) 47 | 48 | (define (->parent parent) 49 | (if parent 50 | (with-syntax ((parent parent)) 51 | #'((dummy parent))) 52 | #'())) 53 | 54 | (define (process-accessors k name pred fields) 55 | (with-syntax ((name name) (pred pred)) 56 | (let loop ((fields fields) (r '())) 57 | (syntax-case fields (struct) 58 | (() (reverse r)) 59 | (((type field ref set) rest ...) 60 | (identifier? #'type) 61 | (loop #'(rest ...) 62 | (cons #'((define (ref o) 63 | (unless (pred o) 64 | (assertion-violation 'ref 65 | "It's not a struct instance" o)) 66 | (let* ((p (object->reference-address o)) 67 | (fp (make-ftype-pointer name p))) 68 | (let ((r (ftype-ref name (field) fp))) 69 | (case (pffi-type->foreign-type 'type) 70 | ((void*) (integer->pointer r)) 71 | (else r))))) 72 | (define (set o v) 73 | (unless (pred o) 74 | (assertion-violation 'set 75 | "It's not a struct instance" o)) 76 | (let* ((p (object->reference-address o)) 77 | (fp (make-ftype-pointer name p))) 78 | (ftype-set! name (field) fp (->value v))))) 79 | r))) 80 | ((((struct type) field ref set) rest ...) 81 | (loop #'(rest ...) 82 | (cons #'((define (ref o) 83 | (unless (pred o) 84 | (assertion-violation 'ref 85 | "It's not a struct instance" o)) 86 | (let ((ad (struct-field-address o name field)) 87 | (bv (make-bytevector (ftype-sizeof type)))) 88 | (do ((i 0 (+ i 1))) 89 | ((= i (bytevector-length bv)) bv) 90 | (bytevector-u8-set! bv i 91 | (foreign-ref 'unsigned-8 ad i))))) 92 | (define (set o v) 93 | (unless (pred o) 94 | (assertion-violation 'set 95 | "It's not a struct instance" o)) 96 | (let ((ad (struct-field-address o name field))) 97 | (do ((i 0 (+ i 1))) 98 | ((= i (bytevector-length v))) 99 | (foreign-set! 'unsigned-8 ad i 100 | (bytevector-u8-ref v i)))))) 101 | r))))))) 102 | 103 | (define (->value v) 104 | (if (pointer? v) 105 | (pointer->integer v) 106 | v)) 107 | 108 | (define-syntax struct-field-address 109 | (syntax-rules () 110 | ((_ o name field) 111 | (let* ((p (object->reference-address o)) 112 | (fp (make-ftype-pointer name p))) 113 | (ftype-pointer-address (ftype-&ref name (field) fp)))))) 114 | ) 115 | -------------------------------------------------------------------------------- /src/pffi/ffi-type-descriptor.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/ffi-type-descriptor.sls - Foreign type descriptor 4 | ;;; 5 | ;;; Copyright (c) 2015-2025 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | (library (pffi ffi-type-descriptor) 33 | (export (rename (type-descriptor )) 34 | type-descriptor? 35 | type-descriptor-name type-descriptor-size 36 | 37 | ffi-type-descriptor? make-ffi-type-descriptor 38 | (rename (type-descriptor-name ffi-type-descriptor-name) 39 | (type-descriptor-size ffi-type-descriptor-size)) 40 | ffi-type-descriptor-alias 41 | 42 | pointer-accesible-ffi-type-descriptor? 43 | make-pointer-accesible-ffi-type-descriptor 44 | pointer-accesible-ffi-type-descriptor-pointer-ref 45 | pointer-accesible-ffi-type-descriptor-pointer-set! 46 | 47 | (rename (foreign-struct-descriptor )) 48 | foreign-struct-descriptor? make-foreign-struct-descriptor 49 | (rename (type-descriptor-name foreign-struct-descriptor-name) 50 | (type-descriptor-size foreign-struct-descriptor-size)) 51 | foreign-struct-descriptor-fields 52 | foreign-struct-descriptor-parent 53 | foreign-struct-descriptor-protocol 54 | foreign-struct-descriptor-protocol-set! 55 | foreign-struct-descriptor-has-protocol? 56 | foreign-struct-descriptor-ctr foreign-struct-descriptor-ctr-set! 57 | foreign-struct-descriptor-getters 58 | foreign-struct-descriptor-getters-set! 59 | foreign-struct-descriptor-setters 60 | foreign-struct-descriptor-setters-set! 61 | 62 | make-generic-foreign-struct-descriptor 63 | generic-foreign-struct-descriptor-alignment 64 | generic-foreign-struct-descriptor-type-ref 65 | generic-foreign-struct-descriptor-type-set! 66 | ) 67 | (import (rnrs)) 68 | (define-record-type type-descriptor 69 | (fields name size)) 70 | 71 | ;; primitive types 72 | (define-record-type ffi-type-descriptor 73 | (parent type-descriptor) 74 | (fields alias) 75 | (protocol (lambda (n) 76 | (lambda (name alias size) 77 | ((n name size) alias))))) 78 | 79 | (define-record-type pointer-accesible-ffi-type-descriptor 80 | (parent ffi-type-descriptor) 81 | (fields pointer-ref pointer-set!) 82 | (protocol (lambda (n) 83 | (lambda (name alias size ref set) 84 | ((n name alias size) ref set))))) 85 | 86 | ;; this can be in struct/helper.sls but Guile doesn't like it... 87 | (define-record-type foreign-struct-descriptor 88 | (parent type-descriptor) 89 | (fields fields 90 | parent 91 | (mutable protocol) 92 | has-protocol? 93 | (mutable ctr) 94 | (mutable getters) 95 | (mutable setters)) 96 | (protocol (lambda (p) 97 | (lambda (name size fields parent protocol) 98 | ((p name size) fields parent #f protocol #f '() '()))))) 99 | 100 | ;; this can be struct.sls, but Guile doesn't like it... 101 | (define-record-type generic-foreign-struct-descriptor 102 | (parent foreign-struct-descriptor) 103 | (fields alignment type-ref type-set!) 104 | (protocol (lambda (n) 105 | (lambda (name size alignment fields parent proto ref set) 106 | ((n name size fields parent proto) 107 | alignment ref set))))) 108 | 109 | 110 | ) 111 | -------------------------------------------------------------------------------- /src/pffi/helper.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/helper.chezscheme.sls - Helper for Chez Scheme 4 | ;;; 5 | ;;; Copyright (c) 2022 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | (library (pffi helper) 33 | (export pffi-type->foreign-type 34 | registered-alias? 35 | adjust-argument-types 36 | callback ___ 37 | define-type-alias) 38 | (import (rnrs) 39 | (pffi global) 40 | (only (chezscheme) reverse! define-ftype)) 41 | 42 | ;; Because chez's foreign-procedure is a syntax 43 | ;; we need to do a bit sloppy way of handling typedef... 44 | (define-syntax define-type-alias 45 | (lambda (x) 46 | (define (register-type-alias! name alias) 47 | (hashtable-set! *typedef-table* name alias)) 48 | (syntax-case x (* callback) 49 | ((_ name (* alias)) 50 | (register-type-alias! (syntax->datum #'name) 'void*) 51 | #'(define-ftype name void*)) 52 | ((_ name (callback (conv ...) ret (args ...))) 53 | (register-type-alias! (syntax->datum #'name) (syntax->datum 'void*)) 54 | #'(define-ftype name void*)) 55 | ((_ name (callback ret (args ...))) 56 | (register-type-alias! (syntax->datum #'name) 'void*) 57 | #'(define-ftype name void*)) 58 | ((_ name alias) 59 | (register-type-alias! (syntax->datum #'name) (syntax->datum #'alias)) 60 | #'(define-ftype name alias))))) 61 | 62 | (define (registered-alias? v) (hashtable-ref *typedef-table* v #f)) 63 | 64 | ;; We need it here for free-identifier 65 | (define ___ '___) ;; varargs 66 | (define (pffi-type->foreign-type type) 67 | (define resolved (hashtable-ref *typedef-table* type type)) 68 | (case resolved 69 | ((void ) 'void) 70 | ((char ) 'integer-8) 71 | ((unsigned-char ) 'unsigned-8) 72 | ((short ) 'short) 73 | ((unsigned-short) 'unsigned-short) 74 | ((int ) 'int) 75 | ((unsigned-int ) 'unsigned-int) 76 | ((long ) 'long) 77 | ((unsigned-long ) 'unsigned-long) 78 | ((int8_t ) 'integer-8) 79 | ((uint8_t ) 'unsigned-8) 80 | ((int16_t ) 'integer-16) 81 | ((uint16_t ) 'unsigned-16) 82 | ((int32_t ) 'integer-32) 83 | ((uint32_t ) 'unsigned-32) 84 | ((int64_t ) 'integer-64) 85 | ((uint64_t ) 'unsigned-64) 86 | ((double ) 'double) 87 | ((float ) 'float) 88 | ((pointer ) 'void*) 89 | ((___ ) #f) ;; ignore this for Chez 90 | ;; let chez complain if not defined 91 | (else (if (eq? resolved type) 92 | resolved 93 | ;; maybe typedef of typedef 94 | (pffi-type->foreign-type resolved))))) 95 | 96 | (define-syntax callback 97 | (syntax-rules () 98 | ((_ ignore ...) void*))) 99 | 100 | (define (adjust-argument-types args) 101 | (define (types args acc varargs?) 102 | (syntax-case args (callback ___) 103 | (() (list (reverse! acc) varargs?)) 104 | (((callback ret (ignore ...)) rest ...) 105 | (types #'(rest ...) (cons #'void* acc) varargs?)) 106 | (((callback ignore ...) rest ...) 107 | (syntax-violation 'foreign-procedure "Invalid callback format" args)) 108 | ((___ a rest ...) 109 | (syntax-violation 'foreign-procedure "___ must be the last" args)) 110 | ((___) (types #'() acc #t)) 111 | ((type rest ...) (types #'(rest ...) (cons #'type acc) varargs?)))) 112 | (types args '() #f)) 113 | ) 114 | -------------------------------------------------------------------------------- /src/pffi.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi.sls - Portable Foreign Function Interface 4 | ;;; 5 | ;;; Copyright (c) 2015-2019 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | #!r6rs 32 | (library (pffi) 33 | (export foreign-procedure 34 | c-callback 35 | free-c-callback 36 | open-shared-object 37 | lookup-shared-object 38 | ;; TODO should we export these primitives? 39 | ;; make-c-function 40 | ;; make-c-callback 41 | 42 | ;; primitive types 43 | char unsigned-char 44 | short unsigned-short 45 | int unsigned-int 46 | long unsigned-long 47 | float double 48 | int8_t uint8_t 49 | int16_t uint16_t 50 | int32_t uint32_t 51 | int64_t uint64_t 52 | pointer callback 53 | void boolean wchar 54 | ___ 55 | 56 | size-of-unsigned-char 57 | size-of-char 58 | size-of-unsigned-short 59 | size-of-short 60 | size-of-unsigned-int 61 | size-of-int 62 | size-of-unsigned-long 63 | size-of-long 64 | size-of-float 65 | size-of-double 66 | size-of-pointer 67 | size-of-boolean 68 | size-of-int8_t 69 | size-of-int16_t 70 | size-of-int32_t 71 | size-of-int64_t 72 | size-of-uint8_t 73 | size-of-uint16_t 74 | size-of-uint32_t 75 | size-of-uint64_t 76 | size-of-wchar 77 | 78 | ;; pointer ref 79 | pointer-ref-c-uint8 80 | pointer-ref-c-int8 81 | pointer-ref-c-uint16 82 | pointer-ref-c-int16 83 | pointer-ref-c-uint32 84 | pointer-ref-c-int32 85 | pointer-ref-c-uint64 86 | pointer-ref-c-int64 87 | pointer-ref-c-unsigned-char 88 | pointer-ref-c-char 89 | pointer-ref-c-unsigned-short 90 | pointer-ref-c-short 91 | pointer-ref-c-unsigned-int 92 | pointer-ref-c-int 93 | pointer-ref-c-unsigned-long 94 | pointer-ref-c-long 95 | pointer-ref-c-float 96 | pointer-ref-c-double 97 | pointer-ref-c-pointer 98 | pointer-ref-c-wchar 99 | 100 | ;; pointer set 101 | pointer-set-c-uint8! 102 | pointer-set-c-int8! 103 | pointer-set-c-uint16! 104 | pointer-set-c-int16! 105 | pointer-set-c-uint32! 106 | pointer-set-c-int32! 107 | pointer-set-c-uint64! 108 | pointer-set-c-int64! 109 | pointer-set-c-unsigned-char! 110 | pointer-set-c-char! 111 | pointer-set-c-unsigned-short! 112 | pointer-set-c-short! 113 | pointer-set-c-unsigned-int! 114 | pointer-set-c-int! 115 | pointer-set-c-unsigned-long! 116 | pointer-set-c-long! 117 | pointer-set-c-float! 118 | pointer-set-c-double! 119 | pointer-set-c-pointer! 120 | pointer-set-c-wchar! 121 | 122 | ;; typedef 123 | define-type-alias * 124 | 125 | ;; variable 126 | define-foreign-variable array 127 | 128 | pointer? 129 | null-pointer? 130 | bytevector->pointer 131 | pointer->bytevector 132 | pointer->integer 133 | integer->pointer 134 | 135 | ;; struct 136 | define-foreign-struct 137 | define-foreign-union 138 | fields parent protocol ;; for convenience 139 | struct alignment 140 | ) 141 | (import (pffi procedure) 142 | (pffi variable) 143 | (pffi pointers) 144 | (pffi struct) 145 | (only (rnrs) define *)) 146 | 147 | (define size-of-unsigned-char size-of-char) 148 | (define size-of-unsigned-short size-of-short) 149 | (define size-of-unsigned-int size-of-int) 150 | (define size-of-unsigned-long size-of-long) 151 | (define size-of-uint8_t size-of-int8_t) 152 | (define size-of-uint16_t size-of-int16_t) 153 | (define size-of-uint32_t size-of-int32_t) 154 | (define size-of-uint64_t size-of-int64_t) 155 | ) 156 | -------------------------------------------------------------------------------- /src/pffi/struct.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/struct.chezscheme.sls - Foreign structure for Chez 4 | ;;; 5 | ;;; Copyright (c) 2015-2025 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; Interact with Chez ftype, we need to have extra compat layer for Chez 32 | 33 | #!r6rs 34 | (library (pffi struct) 35 | (export define-foreign-struct 36 | define-foreign-union 37 | fields parent protocol alignment struct) 38 | (import (rnrs) 39 | (pffi compat) 40 | (pffi helper) 41 | (pffi struct helper) 42 | (pffi struct chez) 43 | (pffi ffi-type-descriptor) 44 | (only (chezscheme) 45 | define-ftype ftype-sizeof make-weak-eq-hashtable)) 46 | 47 | (define *type-descriptors* (make-weak-eq-hashtable)) 48 | ;; use fields, protocol and parent from (rnrs) 49 | ;; e.g. 50 | ;; (define-foreign-struct foreign-vector 51 | ;; (fields (int size) 52 | ;; (pointer elements)) 53 | ;; (protocol 54 | ;; (lambda (p) 55 | ;; (lambda (size) 56 | ;; (p size (bytevector->pointer (make-bytevector size))))))) 57 | (define-syntax define-foreign-struct 58 | (lambda (x) 59 | (define process-clauses 60 | (make-process-clauses x 'define-foreign-struct 61 | (fields parent protocol alginment))) 62 | (define ->type-name (make->type-name 'define-foreign-struct (struct))) 63 | (syntax-case x () 64 | ((k (name ctr pred) specs ...) 65 | (and (identifier? #'name) (identifier? #'ctr) (identifier? #'pred)) 66 | (with-syntax (((((type field ref set) ...) parent protocol alignment) 67 | (process-clauses #'k #'name #'(specs ...))) 68 | (sizeof (->sizeof #'k #'name)) 69 | ((name) (->type-name #'(name)))) 70 | (with-syntax (((ft ...) (->type-name #'(type ...))) 71 | (((define-ref define-set!) ...) 72 | (process-accessors #'k #'name #'pred 73 | #'((type field ref set) ...)))) 74 | #`(begin 75 | (define-ftype name (struct #,@(->parent #'parent) (field ft) ...)) 76 | (define this-protocol protocol) 77 | (define sizeof (ftype-sizeof name)) 78 | (define dummy 79 | (make-foreign-struct-descriptor 80 | 'name 81 | sizeof 82 | '((field type) ...) 83 | (hashtable-ref *type-descriptors* 'parent #f) 84 | this-protocol)) 85 | (define ctr (make-constructor dummy this-protocol)) 86 | (define (pred o) 87 | (and (bytevector? o) 88 | (>= (bytevector-length o) sizeof))) 89 | define-ref ... 90 | define-set! ... 91 | (define dummy2 92 | (begin 93 | (hashtable-set! *type-descriptors* 'name dummy) 94 | (foreign-struct-descriptor-ctr-set! dummy ctr) 95 | (foreign-struct-descriptor-getters-set! dummy (list ref ...)) 96 | (foreign-struct-descriptor-setters-set! dummy (list set ...)) 97 | (foreign-struct-descriptor-protocol-set! dummy 98 | (or this-protocol (default-protocol dummy))))) 99 | )))) 100 | ((k name specs ...) 101 | (identifier? #'name) 102 | (with-syntax (((ctr pred) (->ctr&pred #'k #'name))) 103 | #'(k (name ctr pred) specs ...)))))) 104 | 105 | (define-syntax define-foreign-union 106 | (lambda (x) 107 | (define process-clauses 108 | (make-process-clauses x 'define-foreign-union 109 | (fields parent protocol alginment))) 110 | (define ->type-name (make->type-name 'define-foreign-union (struct))) 111 | (syntax-case x () 112 | ((k (name ctr pred) specs ...) 113 | (and (identifier? #'name) (identifier? #'ctr) (identifier? #'pred)) 114 | (with-syntax (((((type field ref set) ...) parent protocol alignment) 115 | (process-clauses #'k #'name #'(specs ...))) 116 | (sizeof (->sizeof #'k #'name)) 117 | ((name) (->type-name #'(name)))) 118 | (when #'parent 119 | (syntax-violation 'define-foreign-union "Union can't have parent" x)) 120 | (when #'alignment 121 | (syntax-violation 'define-foreign-union "Union can't have alignment" x)) 122 | (with-syntax (((ft ...) (->type-name #'(type ...))) 123 | (((define-ref define-set!) ...) 124 | (process-accessors #'k #'name #'pred 125 | #'((type field ref set) ...)))) 126 | #`(begin 127 | (define-ftype name (union (field ft) ...)) 128 | (define this-protocol protocol) 129 | (define sizeof (ftype-sizeof name)) 130 | (define dummy 131 | (make-foreign-struct-descriptor 132 | 'name 133 | sizeof 134 | '((field type . #f) ...) 135 | (hashtable-ref *type-descriptors* 'parent #f) 136 | this-protocol)) 137 | (define ctr (make-union-constructor dummy this-protocol)) 138 | (define (pred o) 139 | (and (bytevector? o) 140 | (>= (bytevector-length o) sizeof))) 141 | define-ref ... 142 | define-set! ... 143 | (define dummy2 144 | (begin 145 | (hashtable-set! *type-descriptors* 'name dummy) 146 | (foreign-struct-descriptor-ctr-set! dummy ctr) 147 | (foreign-struct-descriptor-getters-set! dummy (list ref ...)) 148 | (foreign-struct-descriptor-setters-set! dummy (list set ...)) 149 | (foreign-struct-descriptor-protocol-set! dummy 150 | (or this-protocol (default-protocol dummy))))) 151 | )))) 152 | ((k name specs ...) 153 | (identifier? #'name) 154 | (with-syntax (((ctr pred) (->ctr&pred #'k #'name))) 155 | #'(k (name ctr pred) specs ...)))))) 156 | ) 157 | -------------------------------------------------------------------------------- /src/pffi/compat.sagittarius.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.sagittarius.sls - Compatible layer for Sagittarius 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | #!r6rs 37 | (library (pffi compat) 38 | (export (rename (open-shared-library open-shared-object)) 39 | (rename (lookup-shared-library lookup-shared-object)) 40 | make-c-function 41 | make-c-callback 42 | free-c-callback 43 | 44 | ;; primitive types 45 | char unsigned-char 46 | short unsigned-short 47 | int unsigned-int 48 | long unsigned-long 49 | float double 50 | int8_t uint8_t 51 | int16_t uint16_t 52 | int32_t uint32_t 53 | int64_t uint64_t 54 | pointer callback 55 | void boolean 56 | (rename (wchar_t wchar)) 57 | ___ 58 | 59 | ;; pointer ref 60 | pointer-ref-c-uint8 61 | pointer-ref-c-int8 62 | pointer-ref-c-uint16 63 | pointer-ref-c-int16 64 | pointer-ref-c-uint32 65 | pointer-ref-c-int32 66 | pointer-ref-c-uint64 67 | pointer-ref-c-int64 68 | ;; should we define them? 69 | ;; pointer-ref-c-uint8_t 70 | ;; pointer-ref-c-int8_t 71 | ;; pointer-ref-c-uint16_t 72 | ;; pointer-ref-c-int16_t 73 | ;; pointer-ref-c-uint32_t 74 | ;; pointer-ref-c-int32_t 75 | ;; pointer-ref-c-uint64_t 76 | ;; pointer-ref-c-int64_t 77 | pointer-ref-c-unsigned-char 78 | pointer-ref-c-char 79 | pointer-ref-c-unsigned-short 80 | pointer-ref-c-short 81 | pointer-ref-c-unsigned-int 82 | pointer-ref-c-int 83 | pointer-ref-c-unsigned-long 84 | pointer-ref-c-long 85 | pointer-ref-c-float 86 | pointer-ref-c-double 87 | pointer-ref-c-pointer 88 | pointer-ref-c-wchar 89 | 90 | ;; pointer set 91 | pointer-set-c-uint8! 92 | pointer-set-c-int8! 93 | pointer-set-c-uint16! 94 | pointer-set-c-int16! 95 | pointer-set-c-uint32! 96 | pointer-set-c-int32! 97 | pointer-set-c-uint64! 98 | pointer-set-c-int64! 99 | pointer-set-c-unsigned-char! 100 | pointer-set-c-char! 101 | pointer-set-c-unsigned-short! 102 | pointer-set-c-short! 103 | pointer-set-c-unsigned-int! 104 | pointer-set-c-int! 105 | pointer-set-c-unsigned-long! 106 | pointer-set-c-long! 107 | pointer-set-c-float! 108 | pointer-set-c-double! 109 | pointer-set-c-pointer! 110 | pointer-set-c-wchar! 111 | 112 | ;; sizeof 113 | size-of-char 114 | size-of-short 115 | size-of-int 116 | size-of-long 117 | size-of-float 118 | size-of-double 119 | (rename (size-of-void* size-of-pointer) 120 | (size-of-bool size-of-boolean)) 121 | size-of-int8_t 122 | size-of-int16_t 123 | size-of-int32_t 124 | size-of-int64_t 125 | (rename (size-of-wchar_t size-of-wchar)) 126 | 127 | pointer? 128 | bytevector->pointer 129 | pointer->bytevector 130 | pointer->integer 131 | (rename (uinteger->pointer integer->pointer)) 132 | ) 133 | (import (rnrs) 134 | (sagittarius) ;; for cond-expand... 135 | (rename (sagittarius ffi) 136 | (callback %callback) 137 | (make-c-function %make-c-function) 138 | (make-c-callback %make-c-callback) 139 | (char ffi:char) 140 | (unsigned-char ffi:unsigned-char) 141 | (short ffi:short) 142 | (unsigned-short ffi:unsigned-short) 143 | (int ffi:int) 144 | (unsigned-int ffi:unsigned-int) 145 | (long ffi:long) 146 | (unsigned-long ffi:unsigned-long) 147 | (float ffi:float) 148 | (double ffi:double) 149 | (int8_t ffi:int8_t) 150 | (uint8_t ffi:uint8_t) 151 | (int16_t ffi:int16_t) 152 | (uint16_t ffi:uint16_t) 153 | (int32_t ffi:int32_t) 154 | (uint32_t ffi:uint32_t) 155 | (int64_t ffi:int64_t) 156 | (uint64_t ffi:uint64_t) 157 | (wchar_t ffi:wchar_t) 158 | (pointer-ref-c-wchar ffi:pointer-ref-c-wchar) 159 | (pointer-set-c-wchar! ffi:pointer-set-c-wchar!)) 160 | (pffi ffi-type-descriptor) 161 | (srfi :1)) 162 | 163 | (cond-expand 164 | ;; proper wchar_t support is from 0.9.13 165 | ((and cond-expand.version (version (>= "0.9.13"))) 166 | (define (->native-type type) 167 | (cond ((ffi-type-descriptor? type) (ffi-type-descriptor-alias type)) 168 | (else type))) 169 | (define (make-c-function lib conv ret name args) 170 | (%make-c-function lib (->native-type ret) name (map ->native-type args))) 171 | 172 | (define (make-c-callback ret args proc) 173 | (%make-c-callback (->native-type ret) (map ->native-type args) proc)) 174 | ) 175 | ;; other versions must have workaround 176 | (else 177 | (define (->native-type type) 178 | (cond ((ffi-type-descriptor? type) 179 | (let ((alias (ffi-type-descriptor-alias type))) 180 | (if (eq? alias ffi:wchar_t) 181 | (case size-of-wchar_t 182 | ((2) ffi:uint16_t) 183 | ((4) ffi:uint32_t)) 184 | alias))) 185 | (else type))) 186 | 187 | (define (convert-arg type arg) 188 | (cond ((ffi-type-descriptor? type) 189 | (let ((alias (ffi-type-descriptor-alias type))) 190 | (if (eq? alias ffi:wchar_t) 191 | (char->integer arg) 192 | arg))) 193 | ((eq? type ffi:wchar_t) (char->integer arg)) 194 | (else arg))) 195 | (define (convert-arg/guess arg) 196 | (if (char? arg) 197 | (char->integer arg) 198 | arg)) 199 | (define (convert-ret type r) 200 | (cond ((ffi-type-descriptor? type) 201 | (let ((alias (ffi-type-descriptor-alias type))) 202 | (if (eq? alias ffi:wchar_t) 203 | (integer->char r) 204 | r))) 205 | ((eq? type ffi:wchar_t) (integer->char r)) 206 | (else r))) 207 | (define (make-c-function lib conv ret name args) 208 | (let ((proc (%make-c-function lib (->native-type ret) name 209 | (map ->native-type args)))) 210 | (if (memq '___ args) 211 | (lambda formal 212 | (let ((n (- (length args) 1))) 213 | (let-values (((req opts) (split-at formal n))) 214 | (convert-ret ret 215 | (apply proc (append! (map convert-arg args req) 216 | (map convert-arg/guess opts))))))) 217 | (lambda formal 218 | (convert-ret ret (apply proc (map convert-arg args formal))))))) 219 | 220 | (define (make-c-callback ret args proc) 221 | (define (wrapped . args*) 222 | (convert-arg ret (apply proc (map convert-ret args args*)))) 223 | (%make-c-callback (->native-type ret) (map ->native-type args) wrapped)) 224 | )) 225 | 226 | (define-syntax callback 227 | (syntax-rules () 228 | ((_ ignore ...) %callback))) 229 | 230 | (define-syntax define-ftype 231 | (lambda (x) 232 | (define (->type&acc k name) 233 | (define base (symbol->string (syntax->datum name))) 234 | (datum->syntax k 235 | (list (string->symbol (string-append "ffi:" base)) 236 | (string->symbol (string-append "pointer-ref-c-" base)) 237 | (string->symbol (string-append "pointer-set-c-" base "!"))))) 238 | (define (->sizeof k name) 239 | (define base (symbol->string (syntax->datum name))) 240 | (datum->syntax k (string->symbol (string-append "size-of-" base)))) 241 | (syntax-case x () 242 | ((k name) 243 | (with-syntax ((sizeof (->sizeof #'k #'name))) 244 | #'(define-ftype name sizeof))) 245 | ((k name sizeof) 246 | (with-syntax (((type p-ref p-set) (->type&acc #'k #'name))) 247 | #'(define name 248 | (make-pointer-accesible-ffi-type-descriptor 249 | 'name type sizeof p-ref p-set))))))) 250 | 251 | (define-ftype char) 252 | (define-ftype unsigned-char size-of-char) 253 | (define-ftype short) 254 | (define-ftype unsigned-short size-of-short) 255 | (define-ftype int) 256 | (define-ftype unsigned-int size-of-int) 257 | (define-ftype long) 258 | (define-ftype unsigned-long size-of-long) 259 | (define-ftype float) 260 | (define-ftype double) 261 | (define-ftype int8_t) 262 | (define-ftype uint8_t size-of-int8_t) 263 | (define-ftype int16_t) 264 | (define-ftype uint16_t size-of-int16_t) 265 | (define-ftype int32_t) 266 | (define-ftype uint32_t size-of-int32_t) 267 | (define-ftype int64_t) 268 | (define-ftype uint64_t size-of-int64_t) 269 | 270 | (cond-expand 271 | ((and cond-expand.version (version (>= "0.9.13"))) 272 | (define wchar_t 273 | (make-pointer-accesible-ffi-type-descriptor 274 | 'wchar_t wide-character size-of-wchar_t 275 | pointer-ref-c-wide-character pointer-set-c-wide-character!))) 276 | (else (define-ftype wchar_t))) 277 | 278 | ;; Sagittarius returns integer for wchar so wrap it 279 | (define (pointer-ref-c-wchar p off) 280 | (integer->char (ffi:pointer-ref-c-wchar p off))) 281 | (define (pointer-set-c-wchar! p off c) 282 | (ffi:pointer-set-c-wchar! p off (char->integer c))) 283 | 284 | (define pointer (make-pointer-accesible-ffi-type-descriptor 285 | 'pointer void* size-of-void* 286 | pointer-ref-c-pointer pointer-set-c-pointer!)) 287 | (define boolean (make-ffi-type-descriptor 'boolean bool size-of-bool)) 288 | 289 | ) 290 | -------------------------------------------------------------------------------- /src/pffi/struct/helper.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/struct/helper.sls - Foreign structure helper 4 | ;;; 5 | ;;; Copyright (c) 2015-2025 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | #!r6rs 31 | (library (pffi struct helper) 32 | (export ->ctr&pred ->sizeof ->sizeofs 33 | make-process-clauses make->type-name 34 | alignment struct 35 | 36 | default-protocol ;; because of Guile... 37 | make-constructor 38 | make-union-constructor) 39 | (import (for (rnrs) run expand (meta -1)) 40 | (pffi ffi-type-descriptor) 41 | (only (pffi misc) take drop split-at)) 42 | 43 | ;; keyword to distinguish type (for Chez) 44 | (define-syntax struct (syntax-rules ())) 45 | (define-syntax alignment (syntax-rules ())) 46 | 47 | ;; Guile doesn't understand (meta -1) so passing the required free identifiers 48 | ;; explicitly here (i.e. fields, parent, protocol and alignment) 49 | (define-syntax make-process-clauses 50 | (syntax-rules () 51 | ((_ x who (fields parent protocol alginment)) 52 | (lambda (k name clauses) 53 | (define (process-fields k type-name ofields) 54 | (let loop ((fields ofields) (r '())) 55 | (syntax-case fields () 56 | (() (reverse r)) 57 | (((type name) . rest) 58 | (with-syntax (((ref set) (->ref&set! k type-name #'name))) 59 | (loop #'rest (cons #'(type name ref set) r)))) 60 | (((type name ref) . rest) 61 | (with-syntax (((ignore set) (->ref&set! k type-name #'name))) 62 | (loop #'rest (cons #'(type name ref set) r)))) 63 | (((type name ref set) . rest) 64 | (loop #'rest (cons #'(type name ref set) r))) 65 | (_ (syntax-violation who "Invalid field declaration" 66 | x (car fields)))))) 67 | (let loop ((clauses clauses) (fs #f) (par #f) (proto #f) (align #f)) 68 | (syntax-case clauses (fields parent protocol alginment) 69 | (() (list (or fs '()) par proto align)) 70 | (((fields defs (... ...)) . rest) 71 | (or (not fs) 72 | (syntax-violation who "only one fields clause allowed" x 73 | (car clauses))) 74 | (loop #'rest 75 | (process-fields k name #'(defs (... ...))) par proto align)) 76 | (((parent p) . rest) 77 | (or (not par) 78 | (syntax-violation who "only one parent clause allowed" x 79 | (car clauses))) 80 | (loop #'rest fs #'p proto align)) 81 | (((protocol p) . rest) 82 | (or (not proto) 83 | (syntax-violation who "only one protocol clause allowed" x 84 | (car clauses))) 85 | (loop #'rest fs par #'p align)) 86 | (((alignment a) . rest) 87 | (or (not align) 88 | (syntax-violation who "only one alignment clause allowed" x 89 | (car clauses))) 90 | (if (identifier? #'a) 91 | (loop #'rest fs par proto #'a) 92 | ;; Apparently, PLT R6RS creates syntax object against 93 | ;; number / string 94 | (loop #'rest fs par proto (syntax->datum #'a)))) 95 | (_ (syntax-violation who "invalid clause" x (car clauses))))))))) 96 | 97 | (define-syntax make->type-name 98 | (syntax-rules () 99 | ((_ who (struct)) 100 | (lambda (names) 101 | (let loop ((names names) (r '())) 102 | (syntax-case names (struct) 103 | (() (reverse r)) 104 | ((type rest (... ...)) 105 | (identifier? #'type) 106 | (loop #'(rest (... ...)) (cons #'type r))) 107 | (((struct type) rest (... ...)) 108 | (identifier? #'type) 109 | (loop #'(rest (... ...)) (cons #'type r))) 110 | (name (syntax-violation who "invalid type name" names #'name)))))))) 111 | 112 | (define (->ctr&pred k name) 113 | (datum->syntax k (list (->name "make-" name "") (->name "" name "?")))) 114 | 115 | (define (->sizeof k name) (datum->syntax k (->name "size-of-" name ""))) 116 | 117 | (define (->sizeofs k types) 118 | (let loop ((types types) (r '())) 119 | (syntax-case types () 120 | (() (datum->syntax k (reverse r))) 121 | ((a . d) 122 | (loop #'d 123 | (cons (list (syntax->datum #'a) (->name "size-of-" #'a "")) r)))))) 124 | 125 | (define (->ref&set! k name field) 126 | (define s (symbol->string (syntax->datum field))) 127 | (datum->syntax k (list (->name "" name (string-append "-" s)) 128 | (->name "" name (string-append "-" s "-set!"))))) 129 | 130 | (define (->name prefix name suffix) 131 | (let ((base (symbol->string (syntax->datum name)))) 132 | (string->symbol (string-append prefix base suffix)))) 133 | 134 | ;; the same thing as r6rs defines... 135 | 136 | (define (total-field-count desc) 137 | (let loop ((desc desc) (r 0)) 138 | (if desc 139 | (loop (foreign-struct-descriptor-parent desc) 140 | (+ (length (foreign-struct-descriptor-fields desc)) r)) 141 | r))) 142 | 143 | (define (make-struct desc field-values) 144 | (define (set-parent-fields desc bv field-values) 145 | (define (->ordered-paretns desc) 146 | (let loop ((p (foreign-struct-descriptor-parent desc)) (r '())) 147 | (if p 148 | (loop (foreign-struct-descriptor-parent p) (cons p r)) 149 | (reverse r)))) 150 | (let loop ((parents (->ordered-paretns desc)) 151 | (field-values field-values)) 152 | (if (null? parents) 153 | field-values 154 | (let* ((setters (foreign-struct-descriptor-setters (car parents))) 155 | (len (length setters))) 156 | (for-each (lambda (set arg) (set bv arg)) 157 | setters (take field-values len)) 158 | (loop (cdr parents) (drop field-values len)))))) 159 | (let ((setters (foreign-struct-descriptor-setters desc)) 160 | (bv (make-bytevector (foreign-struct-descriptor-size desc) 0))) 161 | (let ((field-values (set-parent-fields desc bv field-values))) 162 | (for-each (lambda (set arg) (set bv arg)) setters field-values) 163 | bv))) 164 | 165 | (define (make-simple-conser protocol desc argc) 166 | (protocol 167 | (lambda field-values 168 | (if (= (length field-values) argc) 169 | (make-struct desc field-values) 170 | (assertion-violation "struct constructor" 171 | "wrong number of arguments" 172 | field-values))))) 173 | 174 | (define (make-nested-conser protocol odesc argc) 175 | (protocol 176 | ((let loop ((desc odesc)) 177 | (cond ((foreign-struct-descriptor-parent desc) 178 | => (lambda (parent) 179 | (lambda extra-field-values 180 | (lambda protocol-args 181 | (lambda this-field-values 182 | (apply ((foreign-struct-descriptor-protocol parent) 183 | (apply (loop parent) 184 | (append this-field-values 185 | extra-field-values))) 186 | protocol-args)))))) 187 | (else 188 | (lambda extra-field-values 189 | (lambda this-field-values 190 | (let ((field-values (append this-field-values 191 | extra-field-values))) 192 | (if (= (length field-values) argc) 193 | (make-struct odesc field-values) 194 | (assertion-violation "struct constructor" 195 | "wrong number of arguments" 196 | field-values))))))))))) 197 | 198 | (define (default-protocol desc) 199 | (let ((parent (foreign-struct-descriptor-parent desc))) 200 | (if parent 201 | (let ((parent-field-count (total-field-count parent))) 202 | (lambda (p) 203 | (lambda field-values 204 | (let-values (((parent-field-values this-field-values) 205 | (split-at field-values parent-field-count))) 206 | (let ((n (apply p parent-field-values))) 207 | (apply n this-field-values)))))) 208 | (lambda (p) 209 | (lambda field-values 210 | (apply p field-values)))))) 211 | 212 | ;; TODO implement it properly... 213 | (define (make-constructor desc protocol) 214 | (let ((parent? (foreign-struct-descriptor-parent desc)) 215 | (protocol (or protocol (default-protocol desc)))) 216 | (if parent? 217 | ;; check parent protocol 218 | (begin 219 | (when (and (foreign-struct-descriptor-has-protocol? parent?) 220 | (not (foreign-struct-descriptor-has-protocol? desc))) 221 | (assertion-violation 'make-constructor 222 | "parent has custom protocol" desc)) 223 | (make-nested-conser protocol desc 224 | (total-field-count desc))) 225 | (make-simple-conser protocol desc 226 | (length (foreign-struct-descriptor-fields desc)))))) 227 | 228 | (define (make-union-constructor desc protocol) 229 | (define fields (map car (foreign-struct-descriptor-fields desc))) 230 | (define sizeof (foreign-struct-descriptor-size desc)) 231 | (define (custom-ctr . field&value) 232 | (define f (and (not (null? field&value)) (car field&value))) 233 | (define v (and (not (null? field&value)) 234 | (not (null? (cdr field&value))) 235 | (cadr field&value))) 236 | (define setters (foreign-struct-descriptor-setters desc)) 237 | (let ((r (make-bytevector sizeof 0))) 238 | ;; a bit inefficient... 239 | (when (and f v) 240 | (do ((i 0 (+ i 1)) (f* fields (cdr f*))) 241 | ((or (null? f*) (eq? (car f*) f)) 242 | (unless (null? f*) 243 | (let ((s (list-ref setters i))) 244 | (s r v)))) 245 | )) 246 | r)) 247 | (if protocol 248 | (protocol custom-ctr) 249 | (lambda () (make-bytevector sizeof 0)))) 250 | 251 | ) 252 | -------------------------------------------------------------------------------- /src/pffi/compat.mosh.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.mosh.sls - Compatible layer for Mosh 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | #!r6rs 37 | (library (pffi compat) 38 | (export (rename (open-shared-library open-shared-object)) 39 | (rename (lookup-shared-library lookup-shared-object)) 40 | make-c-function 41 | make-c-callback 42 | free-c-callback 43 | 44 | ;; primitive types 45 | char unsigned-char 46 | short unsigned-short 47 | int unsigned-int 48 | long unsigned-long 49 | float double 50 | int8_t uint8_t 51 | int16_t uint16_t 52 | int32_t uint32_t 53 | int64_t uint64_t 54 | pointer callback 55 | void 56 | 57 | ;; pointer ref 58 | pointer-ref-c-uint8 59 | pointer-ref-c-int8 60 | pointer-ref-c-uint16 61 | pointer-ref-c-int16 62 | pointer-ref-c-uint32 63 | pointer-ref-c-int32 64 | pointer-ref-c-uint64 65 | pointer-ref-c-int64 66 | pointer-ref-c-unsigned-char 67 | (rename (pointer-ref-c-signed-char pointer-ref-c-char)) 68 | pointer-ref-c-unsigned-short 69 | pointer-ref-c-short 70 | pointer-ref-c-unsigned-int 71 | pointer-ref-c-int 72 | pointer-ref-c-unsigned-long 73 | pointer-ref-c-long 74 | pointer-ref-c-float 75 | pointer-ref-c-double 76 | pointer-ref-c-pointer 77 | 78 | ;; pointer set 79 | pointer-set-c-uint8! 80 | pointer-set-c-int8! 81 | pointer-set-c-uint16! 82 | pointer-set-c-int16! 83 | pointer-set-c-uint32! 84 | pointer-set-c-int32! 85 | pointer-set-c-uint64! 86 | pointer-set-c-int64! 87 | ;; Mosh doesn't have pointer-set for unsigned types 88 | ;; well we don't make effort 89 | (rename (pointer-set-c-char! pointer-set-c-unsigned-char!)) 90 | pointer-set-c-char! 91 | pointer-set-c-unsigned-short! 92 | pointer-set-c-short! 93 | pointer-set-c-unsigned-int! 94 | pointer-set-c-int! 95 | pointer-set-c-unsigned-long! 96 | pointer-set-c-long! 97 | pointer-set-c-float! 98 | pointer-set-c-double! 99 | pointer-set-c-pointer! 100 | 101 | size-of-char 102 | size-of-short 103 | size-of-int 104 | size-of-long 105 | size-of-float 106 | size-of-double 107 | size-of-pointer 108 | size-of-int8_t 109 | size-of-int16_t 110 | size-of-int32_t 111 | size-of-int64_t 112 | 113 | pointer? 114 | bytevector->pointer 115 | pointer->bytevector 116 | pointer->integer 117 | integer->pointer 118 | ) 119 | (import (rnrs) 120 | (rename (except (mosh ffi) 121 | ;; Seems mosh computes offset as multiple of 122 | ;; sizeof(type). this I think inconvenient. 123 | pointer-ref-c-uint16 124 | pointer-ref-c-int16 125 | pointer-ref-c-uint32 126 | pointer-ref-c-int32 127 | pointer-ref-c-uint64 128 | pointer-ref-c-int64 129 | pointer-ref-c-unsigned-short 130 | pointer-ref-c-unsigned-int 131 | pointer-ref-c-unsigned-long 132 | pointer-ref-c-float 133 | pointer-ref-c-double 134 | pointer-ref-c-pointer 135 | pointer-set-c-uint16! 136 | pointer-set-c-int16! 137 | pointer-set-c-uint32! 138 | pointer-set-c-int32! 139 | pointer-set-c-uint64! 140 | pointer-set-c-int64! 141 | pointer-set-c-short! 142 | pointer-set-c-int! 143 | pointer-set-c-long! 144 | ;;pointer-set-c-unsigned-int! 145 | ;;pointer-set-c-unsigned-long! 146 | pointer-set-c-float! 147 | pointer-set-c-double! 148 | pointer-set-c-pointer!) 149 | (lookup-shared-library %lookup-shared-library)) 150 | (rename (pffi bv-pointer) 151 | (bytevector->pointer %bytevector->pointer))) 152 | 153 | (define char 'char) 154 | (define unsigned-char 'unsigned-char) 155 | (define short 'short) 156 | (define unsigned-short 'unsigned-short) 157 | (define int 'int) 158 | (define unsigned-int 'unsigned-int) 159 | (define long 'long) 160 | (define unsigned-long 'unsigned-long) 161 | (define float 'float) 162 | (define double 'double) 163 | (define int8_t 'int8_t) 164 | (define uint8_t 'uint8_t) 165 | (define int16_t 'int16_t) 166 | (define uint16_t 'uint16_t) 167 | (define int32_t 'int32_t) 168 | (define uint32_t 'uint32_t) 169 | (define int64_t 'int64_t) 170 | (define uint64_t 'uint64_t) 171 | (define-syntax callback 172 | (syntax-rules () 173 | ((_ ignore ...) 'callback))) 174 | (define void 'void) 175 | (define pointer 'void*) 176 | 177 | (define (lookup-shared-library lib name) 178 | (%lookup-shared-library lib (string->symbol name))) 179 | 180 | (define size-of-char 1) 181 | (define size-of-int8_t 1) 182 | (define size-of-int16_t 2) 183 | (define size-of-int32_t 4) 184 | (define size-of-int64_t 8) 185 | 186 | (define size-of-int16 size-of-int16_t) 187 | (define size-of-uint16 size-of-int16_t) 188 | (define size-of-int32 size-of-int32_t) 189 | (define size-of-uint32 size-of-int32_t) 190 | (define size-of-int64 size-of-int64_t) 191 | (define size-of-uint64 size-of-int64_t) 192 | 193 | (define (bytevector->pointer bv . maybe-offset) 194 | ;; offset will always be ignored. 195 | (%bytevector->pointer bv)) 196 | 197 | (define (pointer->bytevector p len . maybe-offset) 198 | ;; this is not what I want but no way to do on Mosh 199 | ;; we want shared bytevector 200 | (let ((offset (if (null? maybe-offset) 0 (car maybe-offset)))) 201 | (do ((bv (make-bytevector len)) (i 0 (+ i 1))) 202 | ((= i len) bv) 203 | (bytevector-u8-set! bv i (pointer-ref-c-uint8 p (+ i offset)))))) 204 | 205 | (define-syntax define-deref 206 | (lambda (x) 207 | (define (gen-name t) 208 | (let ((s (symbol->string (syntax->datum t)))) 209 | (list (string->symbol (string-append "size-of-" s)) 210 | (string->symbol (string-append "pointer-ref-c-" s)) 211 | (string->symbol (string-append "pointer-set-c-" s "!"))))) 212 | (syntax-case x () 213 | ((k type bv-ref ->bv) 214 | (with-syntax (((size ref set!) (datum->syntax #'k (gen-name #'type)))) 215 | #'(begin 216 | (define (ref ptr offset) 217 | (let ((bv (make-bytevector size))) 218 | (do ((i 0 (+ i 1))) 219 | ((= i size) (bv-ref bv 0 (native-endianness))) 220 | (bytevector-u8-set! bv i 221 | (pointer-ref-c-uint8 ptr (+ i offset)))))) 222 | (define (set! ptr offset value) 223 | (let ((bv (->bv value))) 224 | (do ((len (bytevector-length bv)) 225 | (i 0 (+ i 1))) 226 | ((= i len)) 227 | (pointer-set-c-uint8! ptr (+ i offset) 228 | (bytevector-u8-ref bv i))))))))))) 229 | 230 | ;; kinda tricky 231 | (define (bytevector-long-ref bv index endian) 232 | (if (= size-of-long 4) 233 | (bytevector-s32-ref bv index endian) 234 | (bytevector-s64-ref bv index endian))) 235 | (define (bytevector-ulong-ref bv index endian) 236 | (if (= size-of-long 4) 237 | (bytevector-u32-ref bv index endian) 238 | (bytevector-u64-ref bv index endian))) 239 | (define (bytevector-pointer-ref bv index endian) 240 | (integer->pointer 241 | (if (= size-of-pointer 4) 242 | (bytevector-u32-ref bv index endian) 243 | (bytevector-u64-ref bv index endian)))) 244 | 245 | (define-syntax define-uint->bv 246 | (syntax-rules () 247 | ((_ name size) 248 | (define (name u) 249 | (uint-list->bytevector (list u) (native-endianness) size))))) 250 | (define-syntax define-sint->bv 251 | (syntax-rules () 252 | ((_ name size) 253 | (define (name s) 254 | (sint-list->bytevector (list s) (native-endianness) size))))) 255 | (define-uint->bv u16->bv 2) 256 | (define-uint->bv u32->bv 4) 257 | (define-uint->bv u64->bv 8) 258 | (define-sint->bv s16->bv 2) 259 | (define-sint->bv s32->bv 4) 260 | (define-sint->bv s64->bv 8) 261 | (define-sint->bv long->bv size-of-long) 262 | (define-sint->bv ulong->bv size-of-long) 263 | 264 | (define (float->bv f) 265 | (let ((bv (make-bytevector 4))) 266 | (bytevector-ieee-single-native-set! bv 0 f) 267 | bv)) 268 | (define (double->bv f) 269 | (let ((bv (make-bytevector 8))) 270 | (bytevector-ieee-double-native-set! bv 0 f) 271 | bv)) 272 | 273 | (define-deref short bytevector-s16-ref s16->bv) 274 | (define-deref unsigned-short bytevector-u16-ref u16->bv) 275 | (define-deref int bytevector-s32-ref s32->bv) 276 | (define-deref unsigned-int bytevector-u32-ref u32->bv) 277 | (define-deref long bytevector-long-ref long->bv) 278 | (define-deref unsigned-long bytevector-ulong-ref ulong->bv) 279 | (define-deref float bytevector-ieee-single-ref float->bv) 280 | (define-deref double bytevector-ieee-double-ref double->bv) 281 | (define-deref int16 bytevector-s16-ref s16->bv) 282 | (define-deref uint16 bytevector-u16-ref u16->bv) 283 | (define-deref int32 bytevector-s32-ref s32->bv) 284 | (define-deref uint32 bytevector-u32-ref u32->bv) 285 | (define-deref int64 bytevector-s64-ref s64->bv) 286 | (define-deref uint64 bytevector-u64-ref u64->bv) 287 | 288 | (define (pointer->bv p) 289 | (uint-list->bytevector (list (pointer->integer p)) 290 | (native-endianness) size-of-pointer)) 291 | (define-deref pointer bytevector-pointer-ref pointer->bv) 292 | 293 | 294 | ) 295 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | R6RS Portable Foreign Function Interface 2 | ======================================== 3 | 4 | PFFI is a portable foreign function interface for R6RS Scheme implementations. 5 | 6 | ## Release notes 7 | 8 | See [ReleasNotes](./ReleaseNotes.md) 9 | 10 | ## Example 11 | 12 | Suppose we have the following C file and will be compiled to `libfoo.so` 13 | 14 | ```c 15 | int add(int a, int b) 16 | { 17 | return a + b; 18 | } 19 | ``` 20 | 21 | Now we want to use the above shared object from Scheme. 22 | 23 | ```scheme 24 | #!r6rs 25 | (import (rnrs) (pffi)) 26 | 27 | (define shared-object (open-shared-object "libfoo.so")) 28 | 29 | (define foo (foreign-procedure shared-object int add (int int))) 30 | 31 | (foo 1 2) ;; => 3 32 | 33 | ``` 34 | 35 | See `examples/` directory for more examples. 36 | 37 | ## APIs 38 | 39 | ### Foreign procedures and variables 40 | 41 | This layer of the APIs wraps implementations specific foreign object 42 | accessing. 43 | 44 | 45 | #### [Procedure] `open-shared-object` _shared-object-name_ 46 | 47 | Returns shared object. 48 | 49 | #### [Macro] `foreign-procedure` _shared-object_ _return-type_ _symbol-name_ (_types_ ...) 50 | #### [Macro] `foreign-procedure` _shared-object_ (_conv_ ...) _return-type_ _symbol-name_ (_types_ ...) 51 | 52 | Lookup foreign procedure _symbol-name_ from given _shared-object_ and returns 53 | foreign procedure. A foreign procedure is a mere procedure so users can just 54 | call as if it's a Scheme procedure. 55 | 56 | If the second form is used, then _conv_ must be implementation specific 57 | calling conventions. For example `__cdecl` for Chez Scheme. 58 | 59 | #### [Macro] `c-callback` _return-type_ (_types_ ...) _proc_ 60 | 61 | Creates a callback. Callback is a mechanism that makes foreign procedure 62 | call Scheme procedure. The given _proc_ is the procedure called from 63 | foreign procedure. 64 | 65 | #### [Procedure] `free-c-callback` _callback_ 66 | 67 | Release allocated callback if needed. 68 | 69 | Callback object may not be released automatically so it is user's responsibilty 70 | to make sure to release it. 71 | 72 | #### [Macro] `define-foreign-variable` _shared-object_ _type_ _symbol-name_ [_scheme-name_] 73 | #### [Macro] `define-foreign-variable` _shared-object_ (* _type_) _symbol-name_ [_scheme-name_] 74 | #### [Macro] `define-foreign-variable` _shared-object_ (array _type_) _symbol-name_ [_scheme-name_] 75 | 76 | Lookup foreign variable _symbol-name_ from given _shared-object_ and binds it 77 | to _scheme-name_. If _scheme-name_ is not given, then it is generated from 78 | _symbol-name_ with following rules: 79 | 80 | - converting to lower case 81 | - converting `_` to `-` 82 | 83 | _type_ must be a type which has `pointer-ref-c-*` and `pointer-set-c-*` 84 | procedure. 85 | 86 | The bound variable is settable, thus `set!` syntax can change the value 87 | if it's allowed. 88 | 89 | If the second form is a readable form of specifying `pointer` as type. 90 | 91 | If the third form is used, then the it creates an reference to an array 92 | pointer, and the _scheme-name_ will be a macro of 3 patterns: 93 | 94 | `_scheme-name_`: to return the raw pointer of the array. 95 | `(_scheme-name_ n)`: to refer the `n`th element of the array. 96 | `(set! _scheme-name_ (n v))`: to set `v` to the `n`th element of the array. 97 | 98 | #### [Macro] `define-type-alias` _name_ _alias_ 99 | #### [Macro] `define-type-alias` _name_ (* _alias_) 100 | 101 | Defines a type alias. Similar mechanism as `typedef` in C. 102 | 103 | If the second form is used, then _name_ will be an alias of the `pointer`. 104 | 105 | ### Foreign types 106 | 107 | Implementations may have own bindings for foreign types. This layer absorbs 108 | the difference. Currently following types are supported. 109 | 110 | - `char` 111 | - `unsigned-char` 112 | - `short` 113 | - `unsigned-short` 114 | - `int` 115 | - `unsigned-int` 116 | - `long` 117 | - `unsigned-long` 118 | - `float` 119 | - `double` 120 | - `int8_t` 121 | - `uint8_t` 122 | - `int16_t` 123 | - `uint16_t` 124 | - `int32_t` 125 | - `uint32_t` 126 | - `int64_t` 127 | - `uint64_t` 128 | - `pointer` 129 | - `boolean` 130 | - `void` 131 | - `wchar` 132 | - `callback` 133 | 134 | Above types are all variable except `callback`. Callback is a procedure 135 | which is called from foreign world to Scheme world. Thus it may need to 136 | have foreign types. 137 | 138 | #### Foreign type size 139 | 140 | The foreign type size can be retrieved from the variable, whose name 141 | is `size-of-{type}`, e.g. `size-of-char`, except `void` and `callback`. 142 | 143 | NOTE: `size-of-boolean` may differs depending on the implementation. 144 | It can be either, 1 or 4. 145 | 146 | #### Variadic arguments 147 | 148 | C's variadic arguments (i.e. argument specified by `...`) can be written by 149 | specifying `___`. For example, suppose we have `sum` C function which takes 150 | an int as the number of the variadic arguments, and variadic arguments. 151 | To specify this, you can write like this 152 | 153 | ```scheme 154 | (foreign-procedure lib int sum (int ___)) 155 | ``` 156 | 157 | The `___` must be the last and must not appear more than once. 158 | 159 | ### Pointer operations 160 | 161 | #### [Procedure] `pointer?` _o_ 162 | 163 | Returns #t if given _o_ is a pointer object. 164 | 165 | #### [Procedure] `null-pointer?` _pointer_ 166 | 167 | Returns #t if given _pointer_ value is 0. 168 | 169 | #### [Procedure] `bytevector->pointer` _bv_ 170 | 171 | Converts given bytevector _bv_ to implementation dependent pointer object. 172 | 173 | #### [Procedure] `pointer->bytevector` _p_ _len_ 174 | 175 | Converts given pointer to bytevector whose length is _len_ and elements are 176 | derefered values of the pointer _p_. 177 | 178 | #### [Procedure] `integer->pointer` _i_ 179 | 180 | Converts given integer _i_ to a pointer object. The given integer _i_ is 181 | the address of returning pointer. 182 | 183 | #### [Procedure] `pointer->integer` _p_ 184 | 185 | Converts given pointer _p_ to an integer. The returning integer represents 186 | the address of the pointer _p_. 187 | 188 | 189 | #### [Procedure] `pointer-ref-c-${type}` _p_ _offset_ 190 | 191 | _${type}_ must be one of the following types: 192 | 193 | - `uint8` 194 | - `int8` 195 | - `uint16` 196 | - `int16` 197 | - `uint32` 198 | - `int32` 199 | - `uint64` 200 | - `int64` 201 | - `unsigned-char` 202 | - `char` 203 | - `unsigned-short` 204 | - `short` 205 | - `unsigned-int` 206 | - `int` 207 | - `unsigned-long` 208 | - `long` 209 | - `float` 210 | - `double` 211 | - `pointer` 212 | - `wchar` 213 | 214 | Returns corresponding type value form give pointer _p_. The _offset_ is 215 | byte offset of the given _p_ not aligned value. 216 | 217 | #### [Procedure] `pointer-set-c-${type}!` _p_ _offset_ _value_ 218 | 219 | _${type}_ must be the same as `pointer-ref-c-${type}`. 220 | 221 | Sets given _value_ which is converted to corresponding type to pointer _p_ 222 | on _offset_ location. _offset_ is byte offset of the given _p_. 223 | 224 | ### Foreign structure 225 | 226 | #### [Macro] `define-foreign-struct` _name_ _spec ..._ 227 | #### [Macro] `define-foreign-struct` (_name_ _ctr_ _pred_) _spec ..._ 228 | 229 | Defines a structure. The macro creates constructor, predicate, size-of 230 | variable and accessors. 231 | 232 | _ctr_ is the constructor which returns newly allocated bytevector whose 233 | size is the size of this struct. 234 | 235 | _pred_ is the predicate, which simply check if the givn object is a 236 | bytevector and it has enough size for this structure. It doesn't distinguish 237 | 2 bytevectors created by 2 different ways as long as it has enough size. 238 | 239 | Size-of variable is created adding `size-of-` prefix to _name_. This 240 | variable contains the size of this structure. 241 | 242 | _spec_ can be one of the followings: 243 | 244 | - (`fields` _field spec ..._) 245 | - (`protocol` _proc_) 246 | - (`parent` _parent-structure_) 247 | - (`alignment` _alignment_) 248 | 249 | The same clause can only appear once. If there are more than one the same 250 | clause, it raises `&syntax`. 251 | 252 | _field spec_ can be one the followings: 253 | 254 | - (`fields` (_type_ _field_)) 255 | - (`fields` (_type_ _field_ _getter_)) 256 | - (`fields` (_type_ _field_ _getter_ _setter_)) 257 | 258 | _type_ must be a type listed in _Foreign types_ section except `callback`, 259 | or `(struct _struct-name_)` for foreigin struct. 260 | 261 | _field_ is the field name. This is used for generating _getter_ and _setter_. 262 | In other words, it doesn't have to be meaningful name as long as _getter_ 263 | and _setter_ is specified. 264 | 265 | _getter_ is an accessor to retrieve the structure field value. If this is not 266 | specified, then it is created by adding `_name_-` prefix to _field_. 267 | 268 | _setter_ is an accessor to set the structure field value. If this is not 269 | specified, then it is created by adding `_name_-` prefix and `-set!` suffix 270 | to _field_. 271 | 272 | _proc_ is a procedure which is the same usage as `define-record-type`'s one. 273 | 274 | _parent-structure_ must be a foreign structure defined by this macro. There 275 | is no actual hierarchy but just putting specified structure in front of 276 | this structure so that it seems it has a hierarchy. For example: 277 | 278 | _alignment_ must be an integer or integer variable of `1`, `2`, `4`, `8` 279 | or `16`. This specifies the struct alignment size. This is equivalent of 280 | `#pragma pack(n)`. 281 | 282 | ```scheme 283 | (define-foreign-struct p 284 | (fields (int count))) 285 | 286 | (define-foreign-struct c 287 | (fields (pointer elements)) 288 | (parent p)) 289 | 290 | (make-c 0 (integer->pointer 0)) 291 | ;; 32 bits -> #vu8(0 0 0 0 0 0 0 0) 292 | ;; 64 bits -> #vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 293 | ``` 294 | 295 | is the same as the following 296 | 297 | ```scheme 298 | (define-foreign-struct p 299 | (fields (int count))) 300 | 301 | (define-foreign-struct c 302 | (fields (p p) 303 | (pointer elements))) 304 | 305 | (make-c (make-p 0) (integer->pointer 0)) 306 | ;; 32 bits -> #vu8(0 0 0 0 0 0 0 0) 307 | ;; 64 bits -> #vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 308 | ``` 309 | 310 | If the first form is used, then _ctr_ and _pred_ are created by adding `make-` 311 | prefix and `?` suffix respectively, like `define-record-type`. 312 | 313 | #### [Macro] `define-foreign-union` _name_ _spec ..._ 314 | 315 | Defines a union structure. The macro creates constructor, predicate, size-of 316 | variable and accessors. The auto generating convension is the same as 317 | `define-foreign-struct` unless its specified. 318 | 319 | The _spec_ can be one of the followings: 320 | 321 | - (`fields` _field spec ..._) 322 | - (`protocol` _proc_) 323 | 324 | The `fields` is the same as `define-foreign-struct`. 325 | 326 | The _proc_ of `protocol` should look like this: 327 | 328 | ```scheme 329 | (lambda (p) 330 | (lamba (f) 331 | (p 'f f))) 332 | ``` 333 | The _p_ takes 0 or 2 arguments. If the first form is used, then it creates 334 | 0 padded bytevector. If the second form is used, then it searches the 335 | field setter named *f* and sets the value _f_. If it's not found, then 336 | it behave as if nothing is passed. 337 | 338 | 339 | ## Supporting implementations 340 | 341 | - Sagittarius (0.9.12 or later) 342 | - Racket (plt-r6rs v8.16 or later) 343 | - Guile (3.0.10 or later) 344 | - Chez Scheme (v10.0.0 or later) 345 | - Capy Scheme (0.1.0 or later) 346 | 347 | The below implementations are no loger supported due to the inactiveness or 348 | officially declared to be archived. 349 | 350 | - ~~Larceny (v0.98)~~ 351 | - ~~Vicare (0.3d7)~~ 352 | - ~~Mosh (0.2.7)~~ 353 | 354 | 355 | ## Limitation per implementations 356 | 357 | ### Vicare 358 | 359 | Vicare doesn't support bytevector to pointer convertion whom converted 360 | pointer is shared with source bytevector. So this behaviour is emulated 361 | on this library. This emulation doesn't work on NULL pointer. So the 362 | following situation doesn't work: 363 | Suppose a shared object set a pointer value to NULL, then initialise it 364 | on a function. Scheme code first loads the pointer, then call the 365 | initialisation function, however the loaded pointer still indicates NULL. 366 | 367 | ### Larceny 368 | 369 | On Larceny, GC may move pointers so converting bytevector uses wrapper 370 | technique the same as Vicare. Thus the same limitation is applied to it. 371 | 372 | ## Capy 373 | 374 | Capy Scheme does not support C callbacks due to the CPS conversion. 375 | If you try to call `c-callback` implementation-restriction-violation is raised. 376 | 377 | ## Misc (Memo) 378 | 379 | ### Why no Ypsilon 380 | 381 | The latest released version of Ypsilon has very limited FFI interface. 382 | The biggest problem is `c-function` is defined as a macro which I think 383 | very limited. 384 | 385 | Trunk repository version has far more APIs but it's not released nor 386 | maintained. Thus it is hard for me to make portable layer for it. 387 | 388 | ### Why no IronScheme 389 | 390 | .Net makes a bit things harder. And its FFI support is very limited. (e.g. 391 | it doesn't work on Mono) 392 | 393 | To support above non supported implementations, your pull request is 394 | the fastest way :) 395 | -------------------------------------------------------------------------------- /src/pffi/compat.vicare.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.vicare.sls - Compatible layer for Vicare 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | #!r6rs 37 | (library (pffi compat) 38 | (export open-shared-object ;; form (vicare ffi) 39 | (rename (%lookup-shared-object lookup-shared-object)) 40 | make-c-function 41 | make-c-callback 42 | free-c-callback 43 | 44 | ;; primitive types 45 | char unsigned-char 46 | short unsigned-short 47 | int unsigned-int 48 | long unsigned-long 49 | float double 50 | int8_t uint8_t 51 | int16_t uint16_t 52 | int32_t uint32_t 53 | int64_t uint64_t 54 | pointer callback 55 | void 56 | 57 | pointer-ref-c-uint8 58 | pointer-ref-c-int8 59 | pointer-ref-c-uint16 60 | pointer-ref-c-int16 61 | pointer-ref-c-uint32 62 | pointer-ref-c-int32 63 | pointer-ref-c-uint64 64 | pointer-ref-c-int64 65 | pointer-ref-c-unsigned-char 66 | pointer-ref-c-char 67 | pointer-ref-c-unsigned-short 68 | pointer-ref-c-short 69 | pointer-ref-c-unsigned-int 70 | pointer-ref-c-int 71 | pointer-ref-c-unsigned-long 72 | pointer-ref-c-long 73 | pointer-ref-c-float 74 | pointer-ref-c-double 75 | pointer-ref-c-pointer 76 | 77 | ;; pointer set 78 | pointer-set-c-uint8! 79 | pointer-set-c-int8! 80 | pointer-set-c-uint16! 81 | pointer-set-c-int16! 82 | pointer-set-c-uint32! 83 | pointer-set-c-int32! 84 | pointer-set-c-uint64! 85 | pointer-set-c-int64! 86 | pointer-set-c-unsigned-char! 87 | pointer-set-c-char! 88 | pointer-set-c-unsigned-short! 89 | pointer-set-c-short! 90 | pointer-set-c-unsigned-int! 91 | pointer-set-c-int! 92 | pointer-set-c-unsigned-long! 93 | pointer-set-c-long! 94 | pointer-set-c-float! 95 | pointer-set-c-double! 96 | pointer-set-c-pointer! 97 | 98 | ;; sizeof 99 | size-of-char 100 | size-of-short 101 | size-of-int 102 | size-of-long 103 | size-of-float 104 | size-of-double 105 | size-of-pointer 106 | size-of-int8_t 107 | size-of-int16_t 108 | size-of-int32_t 109 | size-of-int64_t 110 | 111 | (rename (pointer-wrapper? pointer?)) 112 | bytevector->pointer 113 | pointer->bytevector 114 | (rename (%pointer->integer pointer->integer) 115 | (%integer->pointer integer->pointer)) 116 | ) 117 | (import (rnrs) 118 | (rename (except (vicare ffi) 119 | pointer-ref-c-sint8 120 | pointer-ref-c-uint16 121 | pointer-ref-c-sint16 122 | pointer-ref-c-uint32 123 | pointer-ref-c-sint32 124 | pointer-ref-c-uint64 125 | pointer-ref-c-sint64 126 | pointer-ref-c-unsigned-char 127 | pointer-ref-c-unsigned-short 128 | pointer-ref-c-unsigned-int 129 | pointer-ref-c-unsigned-long 130 | pointer-ref-c-float 131 | pointer-ref-c-double 132 | pointer-ref-c-pointer 133 | pointer-set-c-sint8! 134 | pointer-set-c-uint16! 135 | pointer-set-c-sint16! 136 | pointer-set-c-uint32! 137 | pointer-set-c-sint32! 138 | pointer-set-c-uint64! 139 | pointer-set-c-sint64! 140 | pointer-set-c-short! 141 | pointer-set-c-sint! 142 | pointer-set-c-unsigned-char! 143 | pointer-set-c-unsigned-short! 144 | pointer-set-c-unsigned-int! 145 | pointer-set-c-unsigned-long! 146 | pointer-set-c-float! 147 | pointer-set-c-double! 148 | pointer-set-c-pointer!) 149 | (pointer-ref-c-uint8 %pointer-ref-c-uint8) 150 | (pointer-set-c-uint8! %pointer-set-c-uint8!)) 151 | (rename (vicare platform words) 152 | (SIZEOF_CHAR size-of-char) 153 | (SIZEOF_SHORT size-of-short) 154 | (SIZEOF_INT size-of-int) 155 | (SIZEOF_LONG size-of-long) 156 | (SIZEOF_FLOAT size-of-float) 157 | (SIZEOF_DOUBLE size-of-double) 158 | (SIZEOF_POINTER size-of-pointer))) 159 | 160 | 161 | (define char 'signed-char) 162 | (define unsigned-char 'unsigned-char) 163 | (define short 'signed-short) 164 | (define unsigned-short 'unsigned-short) 165 | (define int 'signed-int) 166 | (define unsigned-int 'unsigned-int) 167 | (define long 'signed-long) 168 | (define unsigned-long 'unsigned-long) 169 | (define float 'float) 170 | (define double 'double) 171 | (define int8_t 'int8_t) 172 | (define uint8_t 'uint8_t) 173 | (define int16_t 'int16_t) 174 | (define uint16_t 'uint16_t) 175 | (define int32_t 'int32_t) 176 | (define uint32_t 'uint32_t) 177 | (define int64_t 'int64_t) 178 | (define uint64_t 'uint64_t) 179 | (define pointer 'pointer) 180 | (define-syntax callback 181 | (syntax-rules () 182 | ((_ ignore ...) 'callback))) 183 | ;; seems it's not documented but works 184 | (define void 'void) 185 | 186 | ;; this is needed 187 | (define (sync-pointer arg) 188 | (when (pointer-wrapper? arg) 189 | (let* ((dst (pointer-bytevector arg)) 190 | (len (bytevector-length dst)) 191 | (src (memory->bytevector (pointer-memory arg) len))) 192 | (bytevector-copy! src 0 dst 0 len)))) 193 | 194 | (define (make-c-function lib ret name arg-type) 195 | (define (pointer-handler f) 196 | (define (pointer/value arg) 197 | (if (pointer-wrapper? arg) 198 | (pointer-memory arg) 199 | arg)) 200 | (define (->pointer arg) 201 | (if (pointer? arg) 202 | (make-pointer-wrapper (memory->bytevector arg size-of-pointer) arg) 203 | arg)) 204 | (lambda args 205 | (let-values ((results (apply f (map pointer/value args)))) 206 | (for-each sync-pointer args) 207 | ;; do foreign-procedures return multiple values? 208 | (apply values (map ->pointer results))))) 209 | (let ((func (lookup-shared-object lib (symbol->string name))) 210 | (m (make-c-callout-maker ret arg-type))) 211 | (pointer-handler (m func)))) 212 | 213 | (define (%lookup-shared-object lib name) 214 | (let ((raw-ptr (lookup-shared-object lib name))) 215 | (make-pointer-wrapper (memory->bytevector raw-ptr size-of-pointer) 216 | raw-ptr))) 217 | 218 | ;; FIXME, this probably doesn't work 219 | (define (make-c-callback ret args proc) 220 | (define (pointer-handler f) 221 | (define (pointer/value arg) 222 | (if (pointer? arg) 223 | ;; TODO is this true? 224 | (make-pointer-wrapper (memory->bytevector arg size-of-pointer) arg) 225 | arg)) 226 | (lambda args 227 | (let-values ((results (apply f (map pointer/value args)))) 228 | ;; (for-each sync-pointer results) 229 | ;; argument is passed from foreign world 230 | (apply values results)))) 231 | (let ((m (make-c-callback-maker ret args))) 232 | (m (pointer-handler proc)))) 233 | 234 | 235 | (define size-of-int8_t 1) 236 | (define size-of-int16_t 2) 237 | (define size-of-int32_t 4) 238 | (define size-of-int64_t 8) 239 | (define size-of-uint8_t 1) 240 | (define size-of-uint16_t 2) 241 | (define size-of-uint32_t 4) 242 | (define size-of-uint64_t 8) 243 | 244 | (define size-of-int8 1) 245 | (define size-of-int16 2) 246 | (define size-of-int32 4) 247 | (define size-of-int64 8) 248 | (define size-of-uint8 1) 249 | (define size-of-uint16 2) 250 | (define size-of-uint32 4) 251 | (define size-of-uint64 8) 252 | 253 | 254 | (define size-of-unsigned-char size-of-char) 255 | (define size-of-unsigned-short size-of-short) 256 | (define size-of-unsigned-int size-of-int) 257 | (define size-of-unsigned-long size-of-long) 258 | 259 | 260 | (define-record-type pointer-wrapper 261 | (fields (immutable bytevector pointer-bytevector) 262 | (immutable memory pointer-memory))) 263 | 264 | (define (bytevector->pointer bv . maybe-offset) 265 | ;; unfortunately, there is no procedure which can make a pointer 266 | ;; whose value is shared by the given bytevector on Vicare. 267 | ;; so emulate it. 268 | (let-values (((p size) (bytevector->memory bv))) 269 | (make-pointer-wrapper bv p))) 270 | 271 | (define (pointer->bytevector p len . maybe-offset) 272 | ;; limitation, returning bytevector is not shared with pointer. 273 | (let ((bv (make-bytevector len))) 274 | (bytevector-copy! (pointer-bytevector p) 0 bv 0 len) 275 | bv)) 276 | 277 | ;; do the same trick as Mosh 278 | (define-syntax define-deref 279 | (lambda (x) 280 | (define (gen-name t) 281 | (let ((s (symbol->string (syntax->datum t)))) 282 | (list (string->symbol (string-append "size-of-" s)) 283 | (string->symbol (string-append "pointer-ref-c-" s)) 284 | (string->symbol (string-append "pointer-set-c-" s "!"))))) 285 | (syntax-case x () 286 | ((k type bv-ref ->bv) 287 | (with-syntax (((size ref set!) (datum->syntax #'k (gen-name #'type)))) 288 | #'(begin 289 | (define (ref ptr offset) 290 | (let ((bv (make-bytevector size)) 291 | (p (pointer-memory ptr))) 292 | (do ((i 0 (+ i 1))) 293 | ((= i size) (bv-ref bv 0 (native-endianness))) 294 | (bytevector-u8-set! bv i 295 | (%pointer-ref-c-uint8 p (+ i offset)))))) 296 | (define (set! ptr offset value) 297 | (let ((bv (->bv value)) 298 | (p (pointer-memory ptr))) 299 | (do ((len (bytevector-length bv)) 300 | (i 0 (+ i 1))) 301 | ((= i len) (sync-pointer ptr)) 302 | (%pointer-set-c-uint8! p (+ i offset) 303 | (bytevector-u8-ref bv i))))))))))) 304 | 305 | ;; kinda tricky 306 | (define (bytevector-long-ref bv index endian) 307 | (if (= size-of-long 4) 308 | (bytevector-s32-ref bv index endian) 309 | (bytevector-s64-ref bv index endian))) 310 | (define (bytevector-ulong-ref bv index endian) 311 | (if (= size-of-long 4) 312 | (bytevector-u32-ref bv index endian) 313 | (bytevector-u64-ref bv index endian))) 314 | 315 | (define-syntax define-uint->bv 316 | (syntax-rules () 317 | ((_ name size) 318 | (define (name u) 319 | (uint-list->bytevector (list u) (native-endianness) size))))) 320 | (define-syntax define-sint->bv 321 | (syntax-rules () 322 | ((_ name size) 323 | (define (name s) 324 | (sint-list->bytevector (list s) (native-endianness) size))))) 325 | (define (u8->bv u) (make-bytevector 1 u)) 326 | (define-uint->bv u16->bv 2) 327 | (define-uint->bv u32->bv 4) 328 | (define-uint->bv u64->bv 8) 329 | (define-sint->bv s16->bv 2) 330 | (define-sint->bv s32->bv 4) 331 | (define-sint->bv s64->bv 8) 332 | (define-sint->bv long->bv size-of-long) 333 | (define-sint->bv ulong->bv size-of-long) 334 | 335 | (define (float->bv f) 336 | (let ((bv (make-bytevector 4))) 337 | (bytevector-ieee-single-native-set! bv 0 f) 338 | bv)) 339 | (define (double->bv f) 340 | (let ((bv (make-bytevector 8))) 341 | (bytevector-ieee-double-native-set! bv 0 f) 342 | bv)) 343 | 344 | (define (bytevector-u8-ref/endian bv index endian) 345 | (bytevector-u8-ref bv index)) 346 | (define (bytevector-s8-ref/endian bv index endian) 347 | (bytevector-s8-ref bv index)) 348 | 349 | (define-deref char bytevector-s8-ref/endian u8->bv) 350 | (define-deref unsigned-char bytevector-u8-ref/endian u8->bv) 351 | (define-deref short bytevector-s16-ref s16->bv) 352 | (define-deref unsigned-short bytevector-u16-ref u16->bv) 353 | (define-deref int bytevector-s32-ref s32->bv) 354 | (define-deref unsigned-int bytevector-u32-ref u32->bv) 355 | (define-deref long bytevector-long-ref long->bv) 356 | (define-deref unsigned-long bytevector-ulong-ref ulong->bv) 357 | (define-deref float bytevector-ieee-single-ref float->bv) 358 | (define-deref double bytevector-ieee-double-ref double->bv) 359 | (define-deref int8 bytevector-s8-ref/endian u8->bv) 360 | (define-deref uint8 bytevector-u8-ref/endian u8->bv) 361 | (define-deref int16 bytevector-s16-ref s16->bv) 362 | (define-deref uint16 bytevector-u16-ref u16->bv) 363 | (define-deref int32 bytevector-s32-ref s32->bv) 364 | (define-deref uint32 bytevector-u32-ref u32->bv) 365 | (define-deref int64 bytevector-s64-ref s64->bv) 366 | (define-deref uint64 bytevector-u64-ref u64->bv) 367 | 368 | (define (bytevector-pointer-ref bv index endian) 369 | (let ((i (if (= size-of-pointer 4) 370 | (bytevector-u32-ref bv index endian) 371 | (bytevector-u64-ref bv index endian)))) 372 | (%integer->pointer i))) 373 | (define (pointer-ref-c-pointer p offset) 374 | (bytevector-pointer-ref (pointer-bytevector p) offset (native-endianness))) 375 | (define (pointer-set-c-pointer! p offset ptr) 376 | (let ((src-p (pointer-memory ptr))) 377 | (if (= size-of-pointer 8) 378 | (pointer-set-c-uint64! p offset (pointer->integer src-p)) 379 | (pointer-set-c-uint32! p offset (pointer->integer src-p))))) 380 | 381 | (define (%pointer->integer ptr) 382 | (pointer->integer (pointer-memory ptr))) 383 | (define (%integer->pointer i) 384 | (define (integer->pointer-bv p) 385 | (uint-list->bytevector (list p) 386 | (native-endianness) size-of-pointer)) 387 | (let ((p (integer->pointer i))) 388 | (make-pointer-wrapper (integer->pointer-bv i) p))) 389 | 390 | ) 391 | -------------------------------------------------------------------------------- /src/pffi/compat.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.chezscheme.sls - Compatible layer for Chez Scheme 4 | ;;; 5 | ;;; Copyright (c) 2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | #!r6rs 37 | (library (pffi compat) 38 | (export open-shared-object 39 | lookup-shared-object 40 | make-c-function 41 | make-c-callback 42 | free-c-callback 43 | 44 | ;; primitive types 45 | char unsigned-char 46 | short unsigned-short 47 | int unsigned-int 48 | long unsigned-long 49 | float double 50 | int8_t uint8_t 51 | int16_t uint16_t 52 | int32_t uint32_t 53 | int64_t uint64_t 54 | pointer callback 55 | void boolean wchar 56 | ___ 57 | 58 | ;; pointer ref 59 | pointer-ref-c-uint8 60 | pointer-ref-c-int8 61 | pointer-ref-c-uint16 62 | pointer-ref-c-int16 63 | pointer-ref-c-uint32 64 | pointer-ref-c-int32 65 | pointer-ref-c-uint64 66 | pointer-ref-c-int64 67 | pointer-ref-c-unsigned-char 68 | pointer-ref-c-char 69 | pointer-ref-c-unsigned-short 70 | pointer-ref-c-short 71 | pointer-ref-c-unsigned-int 72 | pointer-ref-c-int 73 | pointer-ref-c-unsigned-long 74 | pointer-ref-c-long 75 | pointer-ref-c-float 76 | pointer-ref-c-double 77 | pointer-ref-c-pointer 78 | pointer-ref-c-wchar 79 | 80 | ;; pointer set 81 | pointer-set-c-uint8! 82 | pointer-set-c-int8! 83 | pointer-set-c-uint16! 84 | pointer-set-c-int16! 85 | pointer-set-c-uint32! 86 | pointer-set-c-int32! 87 | pointer-set-c-uint64! 88 | pointer-set-c-int64! 89 | pointer-set-c-unsigned-char! 90 | pointer-set-c-char! 91 | pointer-set-c-unsigned-short! 92 | pointer-set-c-short! 93 | pointer-set-c-unsigned-int! 94 | pointer-set-c-int! 95 | pointer-set-c-unsigned-long! 96 | pointer-set-c-long! 97 | pointer-set-c-float! 98 | pointer-set-c-double! 99 | pointer-set-c-pointer! 100 | pointer-set-c-wchar! 101 | 102 | ;; sizeof 103 | size-of-char 104 | size-of-short 105 | size-of-int 106 | size-of-long 107 | size-of-float 108 | size-of-double 109 | size-of-pointer 110 | size-of-boolean 111 | (rename (size-of-int8 size-of-int8_t) 112 | (size-of-int16 size-of-int16_t) 113 | (size-of-int32 size-of-int32_t) 114 | (size-of-int64 size-of-int64_t)) 115 | size-of-wchar 116 | 117 | pointer? 118 | bytevector->pointer 119 | pointer->bytevector 120 | pointer->integer 121 | integer->pointer 122 | 123 | ;; Chez-specific exports 124 | pointer-tracker 125 | cleanup-bytevector-locks! 126 | ) 127 | (import (rnrs) 128 | (rnrs eval) 129 | (rename (pffi bv-pointer) 130 | (bytevector->pointer bytevector->address)) 131 | (pffi helper) 132 | (pffi misc) 133 | (only (chezscheme) 134 | void 135 | load-shared-object 136 | lock-object foreign-callable-entry-point 137 | foreign-callable unlock-object 138 | foreign-procedure 139 | ftype-pointer-address ftype-sizeof 140 | foreign-entry foreign-sizeof foreign-ref foreign-set! 141 | make-parameter make-weak-hashtable 142 | collect 143 | make-guardian collect-request-handler)) 144 | 145 | ;; dummy value 146 | (define-record-type shared-object) 147 | (define-record-type ( dummy pointer?)) 148 | ;; general pointer. 149 | (define-record-type integer-pointer 150 | (parent ) 151 | (fields address)) 152 | ;; bytevector pointer, we need this as Chez's GC is generational GC, 153 | ;; means it moves its objects. 154 | ;; NOTE: this doesn't prevent GC during the FFI call, so a bit of 155 | ;; half baked solution, though better than nothing 156 | ;; FIXME: if I have better idea 157 | (define-record-type bytevector-pointer 158 | (parent ) 159 | (fields value)) 160 | (define integer->pointer make-integer-pointer) 161 | (define (pointer->integer p) 162 | (cond ((integer-pointer? p) (integer-pointer-address p)) 163 | ((bytevector-pointer? p) 164 | (bytevector->address (bytevector-pointer-value p))) 165 | (else (assertion-violation 'pointer->integer "pointer required" p)))) 166 | 167 | (define (pointer->bytevector pointer len . maybe-offset) 168 | (cond ((integer-pointer? pointer) 169 | ;; FIXME one way copy 170 | (let ((bv (make-bytevector len))) 171 | (do ((i 0 (+ i 1))) 172 | ((= i len) bv) 173 | (bytevector-u8-set! bv i (pointer-ref-c-uint8 pointer i))))) 174 | ;; This pass should be very rare as callback or returning pointer of 175 | ;; FFI call is constructed from integer. But for the sake of 176 | ;; completeness 177 | ;; TODO Should we check length? 178 | ((bytevector-pointer? pointer) (bytevector-pointer-value pointer)) 179 | (else (assertion-violation 'pointer->bytevector "pointer required" 180 | pointer)))) 181 | 182 | ;; Parameter to allow tracking pointer creation in `bytevector->pointer`. 183 | (define pointer-tracker 184 | (let () 185 | (define (pointer-tracker-check v) 186 | (unless (procedure? v) 187 | (assertion-violation 'pointer-tracker "Given value is not a pointer-tracker" v)) 188 | v) 189 | (define (default bv ptr) 190 | #f) 191 | (make-parameter default pointer-tracker-check))) 192 | 193 | ;; finalizer emulator 194 | (define garbage-pool (make-guardian)) 195 | 196 | (define (bytevector->pointer bv) 197 | ;; We lock for each bytevector->pointer, unlocking happens when 198 | ;; ptr is collected. This way we have to unlock as many times as 199 | ;; there are pointers created. 200 | ;; Lock needs to be taken before we take the pointer. 201 | (lock-object bv) 202 | (guard (err [else (unlock-object bv) (raise-continuable err)]) 203 | (let ([ptr (make-bytevector-pointer bv)]) 204 | ;; bv is registered as representative since we want to access it for unlocking. 205 | (garbage-pool ptr bv) 206 | ((pointer-tracker) bv ptr) 207 | ptr))) 208 | 209 | ;;(define-type-alias void void) 210 | (define-type-alias char integer-8) 211 | (define-type-alias unsigned-char unsigned-8) 212 | (define-type-alias short short) 213 | (define-type-alias unsigned-short unsigned-short) 214 | (define-type-alias int int) 215 | (define-type-alias unsigned-int unsigned-int) 216 | (define-type-alias long long) 217 | (define-type-alias unsigned-long unsigned-long) 218 | (define-type-alias int8_t integer-8) 219 | (define-type-alias uint8_t unsigned-8) 220 | (define-type-alias int16_t integer-16) 221 | (define-type-alias uint16_t unsigned-16) 222 | (define-type-alias int32_t integer-32) 223 | (define-type-alias uint32_t unsigned-32) 224 | (define-type-alias int64_t integer-64) 225 | (define-type-alias uint64_t unsigned-64) 226 | (define-type-alias double double) 227 | (define-type-alias float float) 228 | (define-type-alias pointer void*) 229 | (define-type-alias boolean boolean) 230 | (define-type-alias wchar wchar_t) 231 | 232 | (define (open-shared-object path) 233 | (load-shared-object path) 234 | (make-shared-object)) 235 | (define (lookup-shared-object lib name) 236 | (make-integer-pointer (foreign-entry name))) 237 | 238 | (define (free-c-callback proc) (unlock-object proc)) 239 | 240 | (define (b->p b) (pointer->integer (bytevector->pointer b))) 241 | (define (s->p s) (b->p (string->utf8 (string-append s "\x0;")))) 242 | (define (convert-arg type arg) 243 | (case (pffi-type->foreign-type type) 244 | ((void*) 245 | (cond ((string? arg) (s->p arg)) 246 | ((bytevector? arg) (b->p arg)) 247 | (else (pointer->integer arg)))) 248 | (else arg))) 249 | (define-syntax make-c-function 250 | (lambda (x) 251 | (syntax-case x (quote list) 252 | ((k lib (quote (conv ...)) ret (quote name) (list args ...)) 253 | (identifier? #'name) 254 | (with-syntax ((name-str (symbol->string (syntax->datum #'name))) 255 | (((types ...) varargs?) 256 | (adjust-argument-types #'(args ...)))) 257 | ;; (display #'(types ...)) (newline) 258 | ;; Minor optimisation not to have big code 259 | (if (syntax->datum #'varargs?) 260 | #'(let () 261 | (define procedure-cache (make-weak-hashtable equal-hash equal?)) 262 | (define (object->foreign-type arg) 263 | (cond ((number? arg) 264 | (cond ((and (exact? arg) (integer? arg)) 265 | (let ((n (bitwise-length arg))) 266 | (cond ((<= n 32) 'integer-32) 267 | ((<= n 64) 'integer-64) 268 | (else (assertion-violation 'name 269 | "Too big integer" arg))))) 270 | ;; sorry we don't know if this is 271 | ;; float or double... 272 | ((real? arg) 'double) 273 | (else 274 | (assertion-violation 'name 275 | "Unsuported number" arg)))) 276 | ((or (string? arg) (bytevector? arg) (pointer? arg)) 277 | 'void*) 278 | ((boolean? arg) 'boolean) 279 | (else 280 | (assertion-violation 'name 281 | "Unsuported Scheme object" arg)))) 282 | (define (get-procedure required-types rest-types) 283 | (define arg* `(,@required-types . ,rest-types)) 284 | (cond ((hashtable-ref procedure-cache arg* #f)) 285 | (else 286 | (let ((fp (eval `(foreign-procedure 287 | (__varargs_after 288 | ,(length required-types)) 289 | conv ... name-str ,arg* 290 | ,(pffi-type->foreign-type 'ret)) 291 | (environment '(chezscheme))))) 292 | (hashtable-set! procedure-cache arg* fp) 293 | fp)))) 294 | (let ((required-types (map pffi-type->foreign-type 295 | (drop-right '(args ...) 1)))) 296 | (lambda arg* 297 | (let* ((rest (drop arg* (length required-types))) 298 | (rest-types (map object->foreign-type rest)) 299 | ;; FIXME: We don't want to use `eval` here 300 | ;; to reduce compiled code size. 301 | ;; This may not be an issue as this requires a 302 | ;; special marker for variadic argument. 303 | ;; See: 304 | ;; https://github.com/ktakashi/r6rs-pffi/issues/5 305 | (fp (get-procedure required-types rest-types)) 306 | (r (apply fp (map convert-arg 307 | (append required-types rest-types) 308 | arg*)))) 309 | (case (pffi-type->foreign-type 'ret) 310 | ((void*) (integer->pointer r)) 311 | (else r)))))) 312 | #'(let () 313 | (let ((fp (foreign-procedure conv ... name-str (types ...) ret)) 314 | (arg-types '(args ...))) 315 | (lambda arg* 316 | (let ((r (apply fp (map convert-arg arg-types arg*)))) 317 | (case (pffi-type->foreign-type 'ret) 318 | ((void*) (integer->pointer r)) 319 | (else r)))))))))))) 320 | (define-syntax make-c-callback 321 | (lambda (x) 322 | (syntax-case x (list) 323 | ((k ret (list arg* ...) body) 324 | (with-syntax ((((types ...) varargs?) 325 | (adjust-argument-types #'(arg* ...)))) 326 | #'(let ((args '(types ...))) 327 | (define (wrap proc) 328 | (lambda vals 329 | (let ((r (apply proc (map (lambda (type arg) 330 | (case (pffi-type->foreign-type type) 331 | ((void*) (integer->pointer arg)) 332 | (else arg))) 333 | args vals)))) 334 | (if (pointer? r) 335 | (pointer->integer r) 336 | r)))) 337 | (let ((p (wrap body))) 338 | (define code (foreign-callable p (types ...) ret)) 339 | (lock-object code) 340 | (foreign-callable-entry-point code)))))))) 341 | 342 | (define-syntax define-deref 343 | (lambda (x) 344 | (define (gen-name t) 345 | (let ((s (symbol->string (syntax->datum t)))) 346 | (list (string->symbol (string-append "size-of-" s)) 347 | (string->symbol (string-append "pointer-ref-c-" s)) 348 | (string->symbol (string-append "pointer-set-c-" s "!"))))) 349 | (syntax-case x () 350 | ((k type) 351 | (with-syntax (((size ref set!) (datum->syntax #'k (gen-name #'type)))) 352 | #'(begin 353 | (define size (ftype-sizeof type)) 354 | (define (ref ptr offset) 355 | (foreign-ref (pffi-type->foreign-type 'type) 356 | (pointer->integer ptr) offset)) 357 | (define (set! ptr offset value) 358 | (foreign-set! (pffi-type->foreign-type 'type) 359 | (pointer->integer ptr) offset value))))) 360 | ((k type conv unwrap) 361 | (with-syntax (((size ref set!) (datum->syntax #'k (gen-name #'type)))) 362 | #'(begin 363 | (define size (ftype-sizeof type)) 364 | (define (ref ptr offset) 365 | (conv (foreign-ref (pffi-type->foreign-type 'type) 366 | (pointer->integer ptr) offset))) 367 | (define (set! ptr offset value) 368 | (foreign-set! (pffi-type->foreign-type 'type) 369 | (pointer->integer ptr) offset (unwrap value))))))))) 370 | 371 | (define-type-alias int8 int8_t) 372 | (define-type-alias uint8 uint8_t) 373 | (define-type-alias int16 int16_t) 374 | (define-type-alias uint16 uint16_t) 375 | (define-type-alias int32 int32_t) 376 | (define-type-alias uint32 uint32_t) 377 | (define-type-alias int64 int64_t) 378 | (define-type-alias uint64 uint64_t) 379 | 380 | (define-deref char) 381 | (define-deref unsigned-char) 382 | (define-deref short) 383 | (define-deref unsigned-short) 384 | (define-deref int) 385 | (define-deref unsigned-int) 386 | (define-deref long) 387 | (define-deref unsigned-long) 388 | (define-deref float) 389 | (define-deref double) 390 | (define-deref int8) 391 | (define-deref uint8) 392 | (define-deref int16) 393 | (define-deref uint16) 394 | (define-deref int32) 395 | (define-deref uint32) 396 | (define-deref int64) 397 | (define-deref uint64) 398 | (define-deref pointer make-integer-pointer pointer->integer) 399 | (define-deref wchar) 400 | 401 | (define size-of-boolean (ftype-sizeof boolean)) 402 | 403 | ;; Unlock objects that are referenced by the pool. 404 | (define (cleanup-bytevector-locks!) 405 | (do ((x (garbage-pool) (garbage-pool))) 406 | ((not x)) 407 | (unlock-object x))) 408 | 409 | ;; This has to be the last 410 | (let ((saved (collect-request-handler))) 411 | (collect-request-handler 412 | (lambda () 413 | (saved) 414 | (cleanup-bytevector-locks!)))) 415 | ) 416 | -------------------------------------------------------------------------------- /src/pffi/compat.guile.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.guile.sls - Compatible layer for Guile 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | #!r6rs 37 | (library (pffi compat) 38 | (export open-shared-object 39 | lookup-shared-object 40 | make-c-function 41 | make-c-callback 42 | free-c-callback 43 | 44 | ;; primitive types 45 | char unsigned-char 46 | short unsigned-short 47 | int unsigned-int 48 | long unsigned-long 49 | float double 50 | int8_t uint8_t 51 | int16_t uint16_t 52 | int32_t uint32_t 53 | int64_t uint64_t 54 | pointer callback 55 | void boolean wchar 56 | ___ 57 | 58 | ;; pointer ref 59 | (rename (pointer-ref-c-uint8_t pointer-ref-c-uint8 ) 60 | (pointer-ref-c-int8_t pointer-ref-c-int8 ) 61 | (pointer-ref-c-uint16_t pointer-ref-c-uint16) 62 | (pointer-ref-c-int16_t pointer-ref-c-int16 ) 63 | (pointer-ref-c-uint32_t pointer-ref-c-uint32) 64 | (pointer-ref-c-int32_t pointer-ref-c-int32 ) 65 | (pointer-ref-c-uint64_t pointer-ref-c-uint64) 66 | (pointer-ref-c-int64_t pointer-ref-c-int64 )) 67 | pointer-ref-c-unsigned-char 68 | pointer-ref-c-char 69 | pointer-ref-c-unsigned-short 70 | pointer-ref-c-short 71 | pointer-ref-c-unsigned-int 72 | pointer-ref-c-int 73 | pointer-ref-c-unsigned-long 74 | pointer-ref-c-long 75 | pointer-ref-c-float 76 | pointer-ref-c-double 77 | pointer-ref-c-pointer 78 | pointer-ref-c-wchar 79 | 80 | ;; pointer set 81 | (rename (pointer-set-c-uint8_t! pointer-set-c-uint8! ) 82 | (pointer-set-c-int8_t! pointer-set-c-int8! ) 83 | (pointer-set-c-uint16_t! pointer-set-c-uint16!) 84 | (pointer-set-c-int16_t! pointer-set-c-int16! ) 85 | (pointer-set-c-uint32_t! pointer-set-c-uint32!) 86 | (pointer-set-c-int32_t! pointer-set-c-int32! ) 87 | (pointer-set-c-uint64_t! pointer-set-c-uint64!) 88 | (pointer-set-c-int64_t! pointer-set-c-int64! )) 89 | pointer-set-c-unsigned-char! 90 | pointer-set-c-char! 91 | pointer-set-c-unsigned-short! 92 | pointer-set-c-short! 93 | pointer-set-c-unsigned-int! 94 | pointer-set-c-int! 95 | pointer-set-c-unsigned-long! 96 | pointer-set-c-long! 97 | pointer-set-c-float! 98 | pointer-set-c-double! 99 | pointer-set-c-pointer! 100 | pointer-set-c-wchar! 101 | 102 | ;; sizeof 103 | size-of-char 104 | size-of-short 105 | size-of-int 106 | size-of-long 107 | size-of-float 108 | size-of-double 109 | size-of-pointer 110 | size-of-boolean 111 | size-of-int8_t 112 | size-of-int16_t 113 | size-of-int32_t 114 | size-of-int64_t 115 | size-of-wchar 116 | 117 | pointer? 118 | bytevector->pointer 119 | pointer->bytevector 120 | (rename (pointer-address pointer->integer) 121 | (make-pointer integer->pointer)) 122 | ) 123 | (import (rnrs) 124 | (only (guile) dynamic-link dynamic-pointer uname) 125 | (rename (system foreign) 126 | (short ffi:short) 127 | (unsigned-short ffi:unsigned-short) 128 | (int ffi:int) 129 | (unsigned-int ffi:unsigned-int) 130 | (long ffi:long) 131 | (unsigned-long ffi:unsigned-long) 132 | (float ffi:float) 133 | (double ffi:double)) 134 | (pffi ffi-type-descriptor) 135 | (only (srfi :1) drop-right split-at) 136 | (only (srfi :13) string-index-right)) 137 | 138 | (define size-of-wchar 139 | ;; Very unfortunately, Guile doesn't support wchar_t so we need to 140 | ;; dispatch like this 141 | (case (string->symbol (vector-ref (uname) 0)) 142 | ((Windows) 2) 143 | (else 4))) 144 | 145 | (define (pointer-ref-c-wchar p off) 146 | (let ((bv (pointer->bytevector p (+ size-of-wchar off)))) 147 | (integer->char 148 | (case size-of-wchar 149 | ((2) (bytevector-u16-ref bv off (native-endianness))) 150 | ((4) (bytevector-u32-ref bv off (native-endianness))))))) 151 | (define (pointer-set-c-wchar! p off wc) 152 | (let ((bv (pointer->bytevector p (+ size-of-wchar off))) 153 | (u (char->integer wc))) 154 | (case size-of-wchar 155 | ((2) (bytevector-u16-set! bv off u (native-endianness))) 156 | ((4) (bytevector-u32-set! bv off u (native-endianness)))))) 157 | 158 | (define-syntax callback 159 | (syntax-rules () 160 | ((_ ignore ...) pointer))) 161 | (define-syntax define-ftype 162 | (syntax-rules () 163 | ((_ name type) 164 | (define name 165 | (make-ffi-type-descriptor 'name type (sizeof type)))) 166 | ((_ name type bv-ref bv-set!) 167 | (define name 168 | (make-pointer-accesible-ffi-type-descriptor 169 | 'name type (sizeof type) 170 | (let ((size (sizeof type))) 171 | (lambda (ptr offset) 172 | (let ((bv (pointer->bytevector ptr (+ size offset)))) 173 | (bv-ref bv offset (native-endianness))))) 174 | (let ((size (sizeof type))) 175 | (lambda (ptr offset value) 176 | (let ((bv (pointer->bytevector ptr (+ size offset)))) 177 | (bv-set! bv offset value (native-endianness)))))))))) 178 | 179 | (define-ftype char int8 180 | bytevector-s8-ref/endian bytevector-s8-set/endian!) 181 | (define-ftype unsigned-char uint8 182 | bytevector-u8-ref/endian bytevector-u8-set/endian!) 183 | (define-ftype short ffi:short 184 | bytevector-s16-ref bytevector-s16-set!) 185 | (define-ftype unsigned-short ffi:unsigned-short 186 | bytevector-u16-ref bytevector-u16-set!) 187 | (define-ftype int ffi:int 188 | bytevector-s32-ref bytevector-s32-set!) 189 | (define-ftype unsigned-int ffi:unsigned-int 190 | bytevector-u32-ref bytevector-u32-set!) 191 | (define-ftype long ffi:long 192 | bytevector-long-ref bytevector-long-set!) 193 | (define-ftype unsigned-long ffi:unsigned-long 194 | bytevector-ulong-ref bytevector-ulong-set!) 195 | (define-ftype float ffi:float 196 | bytevector-ieee-single-ref bytevector-ieee-single-set!) 197 | (define-ftype double ffi:double 198 | bytevector-ieee-double-ref bytevector-ieee-double-set!) 199 | (define-ftype int8_t int8 200 | bytevector-s8-ref/endian bytevector-s8-set/endian!) 201 | (define-ftype uint8_t uint8 202 | bytevector-u8-ref/endian bytevector-u8-set/endian!) 203 | (define-ftype int16_t int16 204 | bytevector-s16-ref bytevector-s16-set!) 205 | (define-ftype uint16_t uint16 206 | bytevector-u16-ref bytevector-u16-set!) 207 | (define-ftype int32_t int32 208 | bytevector-s32-ref bytevector-s32-set!) 209 | (define-ftype uint32_t uint32 210 | bytevector-u32-ref bytevector-u32-set!) 211 | (define-ftype int64_t int64 212 | bytevector-s64-ref bytevector-s64-set!) 213 | (define-ftype uint64_t uint64 214 | bytevector-u64-ref bytevector-u64-set!) 215 | (define-ftype pointer '* 216 | bytevector-pointer-ref bytevector-pointer-set!) 217 | (define-ftype boolean int8) ;; use int8 to make the size = 1 218 | (define wchar (make-pointer-accesible-ffi-type-descriptor 219 | 'wchar (case size-of-wchar ((2) uint16) ((4) uint32)) 220 | size-of-wchar pointer-ref-c-wchar pointer-set-c-wchar!)) 221 | 222 | (define ___ '___) ;; dummy 223 | 224 | (define (open-shared-object path) 225 | (let* ((index (string-index-right path #\.)) 226 | (file (if index 227 | (substring path 0 index) 228 | path))) 229 | (dynamic-link file))) 230 | (define (lookup-shared-object lib name) 231 | (dynamic-pointer name lib)) 232 | 233 | (define (free-c-callback proc) #t) ;; for now. 234 | 235 | (define (->native-type type) 236 | (cond ((ffi-type-descriptor? type) (ffi-type-descriptor-alias type)) 237 | (else type))) 238 | 239 | (define (convert-arg type arg) 240 | (define (s->p s) (b->p (string->utf8 (string-append s "\x0;")))) 241 | (define (b->p bv) (bytevector->pointer bv)) 242 | 243 | (cond ((eq? type pointer) 244 | (cond ((string? arg) (s->p arg)) 245 | ((bytevector? arg) (b->p arg)) 246 | ;; Let Guile complain, if not the proper 247 | ;; one 248 | (else arg))) 249 | ((eq? type boolean) 250 | (unless (boolean? arg) 251 | (assertion-violation name "Boolean is required" arg)) 252 | (if arg 1 0)) 253 | ((eq? type wchar) (char->integer arg)) 254 | (else arg))) 255 | 256 | (define (convert-ret type r) 257 | (cond ((eq? type boolean) (eqv? r 1)) 258 | ((eq? type wchar) (integer->char r)) 259 | (else r))) 260 | 261 | (define (make-c-function lib conv ffi:ret name arg-types) 262 | (define ret (->native-type ffi:ret)) 263 | (define ptr (lookup-shared-object lib (symbol->string name))) 264 | 265 | (define (arg->type arg) 266 | ;; it's a bit awkward but no other way 267 | (cond ((number? arg) 268 | (cond ((and (exact? arg) (integer? arg)) 269 | (let ((n (bitwise-length arg))) 270 | (cond ((<= n 32) int32_t) 271 | ((<= n 64) int64_t) 272 | (else (assertion-violation name "Too big integer" 273 | arg))))) 274 | ;; sorry we don't know if this is float or double... 275 | ((real? arg) double) 276 | (else (assertion-violation name "Unsuported number" arg)))) 277 | ((or (string? arg) (bytevector? arg) (pointer? arg)) pointer) 278 | ((boolean? arg) boolean) 279 | ((char? arg) wchar) ;; naive assumption 280 | (else (assertion-violation name "Unsuported type" arg)))) 281 | 282 | (cond ((memq ___ arg-types) => 283 | (lambda (l) 284 | (unless (null? (cdr l)) 285 | (assertion-violation 'make-c-function 286 | "___ must be the last of argument type" arg-types)) 287 | (let ((required-args (remove (lambda (e) (eq? ___ e)) arg-types))) 288 | (lambda args* 289 | (let-values (((required rest) 290 | (split-at args* (- (length required-args) 1)))) 291 | (let* ((real-arg-types (append (drop-right arg-types 1) 292 | (map arg->type rest))) 293 | (fp (pointer->procedure ret ptr 294 | (map ->native-type real-arg-types)))) 295 | (convert-ret ffi:ret 296 | (apply fp (map convert-arg real-arg-types args*))))))))) 297 | (else 298 | (let ((fp (pointer->procedure ret ptr (map ->native-type arg-types)))) 299 | (lambda args* 300 | (convert-ret ffi:ret 301 | (apply fp (map convert-arg arg-types args*)))))))) 302 | 303 | (define (make-c-callback ret args proc) 304 | (define (wrapped . args*) 305 | (convert-arg ret (apply proc (map convert-ret args args*)))) 306 | (procedure->pointer (->native-type ret) wrapped (map ->native-type args))) 307 | 308 | (define-syntax define-deref 309 | (lambda (x) 310 | (define (gen-name t) 311 | (let ((s (symbol->string (syntax->datum t)))) 312 | (list (string->symbol (string-append "pointer-ref-c-" s)) 313 | (string->symbol (string-append "pointer-set-c-" s "!"))))) 314 | (syntax-case x () 315 | ((k type) 316 | (with-syntax (((ref set!) (datum->syntax #'k (gen-name #'type)))) 317 | #'(begin 318 | (define ref 319 | (pointer-accesible-ffi-type-descriptor-pointer-ref type)) 320 | (define set! 321 | (pointer-accesible-ffi-type-descriptor-pointer-set! type)))))))) 322 | (define (bytevector-u8-ref/endian bv index endian) 323 | (bytevector-u8-ref bv index)) 324 | (define (bytevector-u8-set/endian! bv index v endian) 325 | (bytevector-u8-set! bv index v)) 326 | (define (bytevector-s8-ref/endian bv index endian) 327 | (bytevector-s8-ref bv index)) 328 | (define (bytevector-s8-set/endian! bv index v endian) 329 | (bytevector-s8-set! bv index v)) 330 | 331 | ;; kinda tricky 332 | (define (bytevector-long-ref bv index endian) 333 | (if (= size-of-long 4) 334 | (bytevector-s32-ref bv index endian) 335 | (bytevector-s64-ref bv index endian))) 336 | (define (bytevector-long-set! bv index v endian) 337 | (if (= size-of-long 4) 338 | (bytevector-s32-set! bv index v endian) 339 | (bytevector-s64-set! bv index v endian))) 340 | (define (bytevector-ulong-ref bv index endian) 341 | (if (= size-of-long 4) 342 | (bytevector-u32-ref bv index endian) 343 | (bytevector-u64-ref bv index endian))) 344 | (define (bytevector-ulong-set! bv index v endian) 345 | (if (= size-of-long 4) 346 | (bytevector-u32-set! bv index v endian) 347 | (bytevector-u64-set! bv index v endian))) 348 | 349 | 350 | (define-deref char) 351 | (define-deref unsigned-char) 352 | (define-deref short) 353 | (define-deref unsigned-short) 354 | (define-deref int) 355 | (define-deref unsigned-int) 356 | (define-deref long) 357 | (define-deref unsigned-long) 358 | (define-deref float) 359 | (define-deref double) 360 | (define-deref int8_t) 361 | (define-deref uint8_t) 362 | (define-deref int16_t) 363 | (define-deref uint16_t) 364 | (define-deref int32_t) 365 | (define-deref uint32_t) 366 | (define-deref int64_t) 367 | (define-deref uint64_t) 368 | 369 | (define (bytevector-pointer-ref bv index endian) 370 | (make-pointer 371 | (if (= size-of-pointer 4) 372 | (bytevector-u32-ref bv index endian) 373 | (bytevector-u64-ref bv index endian)))) 374 | (define (bytevector-pointer-set! bv index v endian) 375 | (let ((i (pointer-address v))) 376 | (if (= size-of-pointer 4) 377 | (bytevector-u32-set! bv index i endian) 378 | (bytevector-u64-set! bv index i endian)))) 379 | (define-deref pointer) 380 | 381 | 382 | (define-syntax define-sizeof 383 | (lambda (x) 384 | (define (gen-name t) 385 | (let ((s (symbol->string (syntax->datum t)))) 386 | (string->symbol (string-append "size-of-" s)))) 387 | (syntax-case x () 388 | ((k type) 389 | (with-syntax ((name (datum->syntax #'k (gen-name #'type)))) 390 | #'(define name (ffi-type-descriptor-size type))))))) 391 | 392 | (define-sizeof char) 393 | (define-sizeof short) 394 | (define-sizeof int) 395 | (define-sizeof long) 396 | (define-sizeof pointer) 397 | (define-sizeof float) 398 | (define-sizeof double) 399 | (define-sizeof int8_t) 400 | (define-sizeof int16_t) 401 | (define-sizeof int32_t) 402 | (define-sizeof int64_t) 403 | (define-sizeof boolean) 404 | ;; for define-deref 405 | (define size-of-unsigned-char size-of-char) 406 | (define size-of-unsigned-short size-of-short) 407 | (define size-of-unsigned-int size-of-int) 408 | (define size-of-unsigned-long size-of-long) 409 | (define size-of-int8 size-of-int8_t) 410 | (define size-of-uint8 size-of-int8_t) 411 | (define size-of-int16 size-of-int16_t) 412 | (define size-of-uint16 size-of-int16_t) 413 | (define size-of-int32 size-of-int32_t) 414 | (define size-of-uint32 size-of-int32_t) 415 | (define size-of-int64 size-of-int64_t) 416 | (define size-of-uint64 size-of-int64_t) 417 | 418 | ) 419 | -------------------------------------------------------------------------------- /src/pffi/compat.capy.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.capy.sls - Compatible layer for Capy 4 | ;;; 5 | ;;; Copyright (c) 2015 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | 37 | #!r6rs 38 | (library (pffi compat) 39 | (export open-shared-object 40 | lookup-shared-object 41 | make-c-function 42 | make-c-callback 43 | free-c-callback 44 | 45 | ;; primitive types 46 | char unsigned-char 47 | short unsigned-short 48 | int unsigned-int 49 | long unsigned-long 50 | float double 51 | int8_t uint8_t 52 | int16_t uint16_t 53 | int32_t uint32_t 54 | int64_t uint64_t 55 | pointer callback 56 | void boolean wchar 57 | ___ 58 | 59 | ;; pointer ref 60 | (rename (pointer-ref-c-uint8_t pointer-ref-c-uint8)) 61 | (rename (pointer-ref-c-int8_t pointer-ref-c-int8)) 62 | (rename (pointer-ref-c-uint16_t pointer-ref-c-uint16)) 63 | (rename (pointer-ref-c-int16_t pointer-ref-c-int16)) 64 | (rename (pointer-ref-c-uint32_t pointer-ref-c-uint32)) 65 | (rename (pointer-ref-c-int32_t pointer-ref-c-int32)) 66 | (rename (pointer-ref-c-uint64_t pointer-ref-c-uint64)) 67 | (rename (pointer-ref-c-int64_t pointer-ref-c-int64)) 68 | pointer-ref-c-unsigned-char 69 | pointer-ref-c-char 70 | pointer-ref-c-unsigned-short 71 | pointer-ref-c-short 72 | pointer-ref-c-unsigned-int 73 | pointer-ref-c-int 74 | pointer-ref-c-unsigned-long 75 | pointer-ref-c-long 76 | pointer-ref-c-float 77 | pointer-ref-c-double 78 | pointer-ref-c-pointer 79 | pointer-ref-c-wchar 80 | 81 | ;; pointer set 82 | (rename (pointer-set-c-uint8_t! pointer-set-c-uint8!)) 83 | (rename (pointer-set-c-int8_t! pointer-set-c-int8!)) 84 | (rename (pointer-set-c-uint16_t! pointer-set-c-uint16!)) 85 | (rename (pointer-set-c-int16_t! pointer-set-c-int16!)) 86 | (rename (pointer-set-c-uint32_t! pointer-set-c-uint32!)) 87 | (rename (pointer-set-c-int32_t! pointer-set-c-int32!)) 88 | (rename (pointer-set-c-uint64_t! pointer-set-c-uint64!)) 89 | (rename (pointer-set-c-int64_t! pointer-set-c-int64!)) 90 | pointer-set-c-unsigned-char! 91 | pointer-set-c-char! 92 | pointer-set-c-unsigned-short! 93 | pointer-set-c-short! 94 | pointer-set-c-unsigned-int! 95 | pointer-set-c-int! 96 | pointer-set-c-unsigned-long! 97 | pointer-set-c-long! 98 | pointer-set-c-float! 99 | pointer-set-c-double! 100 | pointer-set-c-pointer! 101 | pointer-set-c-wchar! 102 | 103 | ;; sizeof 104 | size-of-char 105 | size-of-short 106 | size-of-int 107 | size-of-long 108 | size-of-float 109 | size-of-double 110 | size-of-pointer 111 | size-of-boolean 112 | size-of-int8_t 113 | size-of-int16_t 114 | size-of-int32_t 115 | size-of-int64_t 116 | size-of-wchar 117 | 118 | pointer? 119 | bytevector->pointer 120 | pointer->bytevector 121 | (rename (pointer-address pointer->integer) 122 | (make-pointer integer->pointer)) 123 | ) 124 | (import (rnrs) 125 | (core foreign-library) 126 | (rename (core foreign) 127 | (short ffi:short) 128 | (unsigned-short ffi:unsigned-short) 129 | (int ffi:int) 130 | (unsigned-int ffi:unsigned-int) 131 | (long ffi:long) 132 | (unsigned-long ffi:unsigned-long) 133 | (float ffi:float) 134 | (double ffi:double)) 135 | (pffi ffi-type-descriptor) 136 | (only (srfi :1) drop-right split-at) 137 | (only (srfi :13) string-index-right)) 138 | 139 | (define size-of-wchar 140 | ;; Very unfortunately, Guile doesn't support wchar_t so we need to 141 | ;; dispatch like this 142 | 4) 143 | 144 | (define (pointer-ref-c-wchar p off) 145 | (let ((bv (pointer->bytevector p (+ size-of-wchar off)))) 146 | (integer->char 147 | (case size-of-wchar 148 | ((2) (bytevector-u16-ref bv off (native-endianness))) 149 | ((4) (bytevector-u32-ref bv off (native-endianness))))))) 150 | (define (pointer-set-c-wchar! p off wc) 151 | (let ((bv (pointer->bytevector p (+ size-of-wchar off))) 152 | (u (char->integer wc))) 153 | (case size-of-wchar 154 | ((2) (bytevector-u16-set! bv off u (native-endianness))) 155 | ((4) (bytevector-u32-set! bv off u (native-endianness)))))) 156 | 157 | (define-syntax callback 158 | (syntax-rules () 159 | ((_ ignore ...) pointer))) 160 | (define-syntax define-ftype 161 | (syntax-rules () 162 | ((_ name type) 163 | (define name 164 | (make-ffi-type-descriptor 'name type (sizeof type)))) 165 | ((_ name type bv-ref bv-set!) 166 | (define name 167 | (make-pointer-accesible-ffi-type-descriptor 168 | 'name type (sizeof type) 169 | (let ((size (sizeof type))) 170 | (lambda (ptr offset) 171 | (let ((bv (pointer->bytevector ptr (+ size offset)))) 172 | (bv-ref bv offset (native-endianness))))) 173 | (let ((size (sizeof type))) 174 | (lambda (ptr offset value) 175 | (let ((bv (pointer->bytevector ptr (+ size offset)))) 176 | (bv-set! bv offset value (native-endianness)))))))))) 177 | 178 | (define-ftype char int8 179 | bytevector-s8-ref/endian bytevector-s8-set/endian!) 180 | (define-ftype unsigned-char uint8 181 | bytevector-u8-ref/endian bytevector-u8-set/endian!) 182 | (define-ftype short ffi:short 183 | bytevector-s16-ref bytevector-s16-set!) 184 | (define-ftype unsigned-short ffi:unsigned-short 185 | bytevector-u16-ref bytevector-u16-set!) 186 | (define-ftype int ffi:int 187 | bytevector-s32-ref bytevector-s32-set!) 188 | (define-ftype unsigned-int ffi:unsigned-int 189 | bytevector-u32-ref bytevector-u32-set!) 190 | (define-ftype long ffi:long 191 | bytevector-long-ref bytevector-long-set!) 192 | (define-ftype unsigned-long ffi:unsigned-long 193 | bytevector-ulong-ref bytevector-ulong-set!) 194 | (define-ftype float ffi:float 195 | bytevector-ieee-single-ref bytevector-ieee-single-set!) 196 | (define-ftype double ffi:double 197 | bytevector-ieee-double-ref bytevector-ieee-double-set!) 198 | (define-ftype int8_t int8 199 | bytevector-s8-ref/endian bytevector-s8-set/endian!) 200 | (define-ftype uint8_t uint8 201 | bytevector-u8-ref/endian bytevector-u8-set/endian!) 202 | (define-ftype int16_t int16 203 | bytevector-s16-ref bytevector-s16-set!) 204 | (define-ftype uint16_t uint16 205 | bytevector-u16-ref bytevector-u16-set!) 206 | (define-ftype int32_t int32 207 | bytevector-s32-ref bytevector-s32-set!) 208 | (define-ftype uint32_t uint32 209 | bytevector-u32-ref bytevector-u32-set!) 210 | (define-ftype int64_t int64 211 | bytevector-s64-ref bytevector-s64-set!) 212 | (define-ftype uint64_t uint64 213 | bytevector-u64-ref bytevector-u64-set!) 214 | (define-ftype pointer '* 215 | bytevector-pointer-ref bytevector-pointer-set!) 216 | (define-ftype boolean int8) ;; use int8 to make the size = 1 217 | (define wchar (make-pointer-accesible-ffi-type-descriptor 218 | 'wchar (case size-of-wchar ((2) uint16) ((4) uint32)) 219 | size-of-wchar pointer-ref-c-wchar pointer-set-c-wchar!)) 220 | 221 | (define ___ '___) ;; dummy 222 | 223 | (define (open-shared-object path) 224 | (let* ((index (string-index-right path #\.)) 225 | (file (if index 226 | (substring path 0 index) 227 | path))) 228 | (load-foreign-library file))) 229 | (define (lookup-shared-object lib name) 230 | (foreign-library-pointer lib name)) 231 | 232 | (define (free-c-callback proc) #t) ;; for now. 233 | 234 | (define (->native-type type) 235 | (cond ((ffi-type-descriptor? type) (ffi-type-descriptor-alias type)) 236 | (else type))) 237 | 238 | (define (convert-arg type arg) 239 | (define (s->p s) (b->p (string->utf8 (string-append s "\x0;")))) 240 | (define (b->p bv) (bytevector->pointer bv)) 241 | 242 | (cond ((eq? type pointer) 243 | (cond ((string? arg) (s->p arg)) 244 | ((bytevector? arg) (b->p arg)) 245 | ;; Let Guile complain, if not the proper 246 | ;; one 247 | (else arg))) 248 | ((eq? type boolean) 249 | (unless (boolean? arg) 250 | (assertion-violation name "Boolean is required" arg)) 251 | (if arg 1 0)) 252 | ((eq? type wchar) (char->integer arg)) 253 | (else arg))) 254 | 255 | (define (convert-ret type r) 256 | (cond ((eq? type boolean) (eqv? r 1)) 257 | ((eq? type wchar) (integer->char r)) 258 | (else r))) 259 | 260 | (define (make-c-function lib conv ffi:ret name arg-types) 261 | (define ret (->native-type ffi:ret)) 262 | (define ptr (lookup-shared-object lib (symbol->string name))) 263 | 264 | (define (arg->type arg) 265 | ;; it's a bit awkward but no other way 266 | (cond ((number? arg) 267 | (cond ((and (exact? arg) (integer? arg)) 268 | (let ((n (bitwise-length arg))) 269 | (cond ((<= n 32) int32_t) 270 | ((<= n 64) int64_t) 271 | (else (assertion-violation name "Too big integer" 272 | arg))))) 273 | ;; sorry we don't know if this is float or double... 274 | ((real? arg) double) 275 | (else (assertion-violation name "Unsuported number" arg)))) 276 | ((or (string? arg) (bytevector? arg) (pointer? arg)) pointer) 277 | ((boolean? arg) boolean) 278 | ((char? arg) wchar) ;; naive assumption 279 | (else (assertion-violation name "Unsuported type" arg)))) 280 | 281 | (cond ((memq ___ arg-types) => 282 | (lambda (l) 283 | (unless (null? (cdr l)) 284 | (assertion-violation 'make-c-function 285 | "___ must be the last of argument type" arg-types)) 286 | (let ((required-args (remove (lambda (e) (eq? ___ e)) arg-types))) 287 | (lambda args* 288 | (let-values (((required rest) 289 | (split-at args* (- (length required-args) 1)))) 290 | (let* ((real-arg-types (append (drop-right arg-types 1) 291 | (map arg->type rest))) 292 | (fp (pointer->procedure ret ptr 293 | (map ->native-type real-arg-types)))) 294 | (convert-ret ffi:ret 295 | (apply fp (map convert-arg real-arg-types args*))))))))) 296 | (else 297 | (let ((fp (pointer->procedure ret ptr (map ->native-type arg-types)))) 298 | (lambda args* 299 | (convert-ret ffi:ret 300 | (apply fp (map convert-arg arg-types args*)))))))) 301 | 302 | ;; NOTE: Capy does not yet support callbacks due to complexity of doing it with CPS conversion 303 | (define (make-c-callback ret args proc) 304 | (implementation-restriction-violation 'make-c-callback "Callbacks are not supported in this implementation.")) 305 | 306 | (define-syntax define-deref 307 | (lambda (x) 308 | (define (gen-name t) 309 | (let ((s (symbol->string (syntax->datum t)))) 310 | (list (string->symbol (string-append "pointer-ref-c-" s)) 311 | (string->symbol (string-append "pointer-set-c-" s "!"))))) 312 | (syntax-case x () 313 | ((k type) 314 | (with-syntax (((ref set!) (datum->syntax #'k (gen-name #'type)))) 315 | #'(begin 316 | (define ref 317 | (pointer-accesible-ffi-type-descriptor-pointer-ref type)) 318 | (define set! 319 | (pointer-accesible-ffi-type-descriptor-pointer-set! type)))))))) 320 | (define (bytevector-u8-ref/endian bv index endian) 321 | (bytevector-u8-ref bv index)) 322 | (define (bytevector-u8-set/endian! bv index v endian) 323 | (bytevector-u8-set! bv index v)) 324 | (define (bytevector-s8-ref/endian bv index endian) 325 | (bytevector-s8-ref bv index)) 326 | (define (bytevector-s8-set/endian! bv index v endian) 327 | (bytevector-s8-set! bv index v)) 328 | 329 | ;; kinda tricky 330 | (define (bytevector-long-ref bv index endian) 331 | (if (= size-of-long 4) 332 | (bytevector-s32-ref bv index endian) 333 | (bytevector-s64-ref bv index endian))) 334 | (define (bytevector-long-set! bv index v endian) 335 | (if (= size-of-long 4) 336 | (bytevector-s32-set! bv index v endian) 337 | (bytevector-s64-set! bv index v endian))) 338 | (define (bytevector-ulong-ref bv index endian) 339 | (if (= size-of-long 4) 340 | (bytevector-u32-ref bv index endian) 341 | (bytevector-u64-ref bv index endian))) 342 | (define (bytevector-ulong-set! bv index v endian) 343 | (if (= size-of-long 4) 344 | (bytevector-u32-set! bv index v endian) 345 | (bytevector-u64-set! bv index v endian))) 346 | 347 | 348 | (define-deref char) 349 | (define-deref unsigned-char) 350 | (define-deref short) 351 | (define-deref unsigned-short) 352 | (define-deref int) 353 | (define-deref unsigned-int) 354 | (define-deref long) 355 | (define-deref unsigned-long) 356 | (define-deref float) 357 | (define-deref double) 358 | (define-deref int8_t) 359 | (define-deref uint8_t) 360 | (define-deref int16_t) 361 | (define-deref uint16_t) 362 | (define-deref int32_t) 363 | (define-deref uint32_t) 364 | (define-deref int64_t) 365 | (define-deref uint64_t) 366 | 367 | 368 | (define (bytevector-pointer-ref bv index endian) 369 | (make-pointer 370 | (if (= size-of-pointer 4) 371 | (bytevector-u32-ref bv index endian) 372 | (bytevector-u64-ref bv index endian)))) 373 | (define (bytevector-pointer-set! bv index v endian) 374 | (let ((i (pointer-address v))) 375 | (if (= size-of-pointer 4) 376 | (bytevector-u32-set! bv index i endian) 377 | (bytevector-u64-set! bv index i endian)))) 378 | (define-deref pointer) 379 | 380 | 381 | (define-syntax define-sizeof 382 | (lambda (x) 383 | (define (gen-name t) 384 | (let ((s (symbol->string (syntax->datum t)))) 385 | (string->symbol (string-append "size-of-" s)))) 386 | (syntax-case x () 387 | ((k type) 388 | (with-syntax ((name (datum->syntax #'k (gen-name #'type)))) 389 | #'(define name (ffi-type-descriptor-size type))))))) 390 | 391 | (define-sizeof char) 392 | (define-sizeof short) 393 | (define-sizeof int) 394 | (define-sizeof long) 395 | (define-sizeof pointer) 396 | (define-sizeof float) 397 | (define-sizeof double) 398 | (define-sizeof int8_t) 399 | (define-sizeof int16_t) 400 | (define-sizeof int32_t) 401 | (define-sizeof int64_t) 402 | (define-sizeof boolean) 403 | ;; for define-deref 404 | (define size-of-unsigned-char size-of-char) 405 | (define size-of-unsigned-short size-of-short) 406 | (define size-of-unsigned-int size-of-int) 407 | (define size-of-unsigned-long size-of-long) 408 | (define size-of-int8 size-of-int8_t) 409 | (define size-of-uint8 size-of-int8_t) 410 | (define size-of-int16 size-of-int16_t) 411 | (define size-of-uint16 size-of-int16_t) 412 | (define size-of-int32 size-of-int32_t) 413 | (define size-of-uint32 size-of-int32_t) 414 | (define size-of-int64 size-of-int64_t) 415 | (define size-of-uint64 size-of-int64_t) 416 | 417 | ) -------------------------------------------------------------------------------- /src/pffi/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;;; -*- mode:scheme; coding: utf-8; -*- 2 | ;;; 3 | ;;; src/pffi/compat.larceny.sls - Compatible layer for Larceny 4 | ;;; 5 | ;;; Copyright (c) 2015-2018 Takashi Kato 6 | ;;; 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | ;;; 11 | ;;; 1. Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | ;;; 14 | ;;; 2. Redistributions in binary form must reproduce the above copyright 15 | ;;; notice, this list of conditions and the following disclaimer in the 16 | ;;; documentation and/or other materials provided with the distribution. 17 | ;;; 18 | ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | ;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | ;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | ;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | ;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | ;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24 | ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25 | ;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | ;;; 30 | 31 | ;; this file provides compatible layer for (pffi procedure) 32 | ;; if implementations can't make this layer, then make 33 | ;; pffi/procedure.$name.sls file so that (pffi) library can 34 | ;; look it up. 35 | 36 | #!r6rs 37 | (library (pffi compat) 38 | (export open-shared-object 39 | lookup-shared-object 40 | 41 | make-c-function 42 | make-c-callback 43 | free-c-callback 44 | 45 | 46 | ;; primitive types 47 | char unsigned-char 48 | short unsigned-short 49 | int unsigned-int 50 | long unsigned-long 51 | float double 52 | int8_t uint8_t 53 | int16_t uint16_t 54 | int32_t uint32_t 55 | int64_t uint64_t 56 | pointer callback 57 | void 58 | ;; pointer ref 59 | pointer-ref-c-uint8 60 | pointer-ref-c-int8 61 | pointer-ref-c-uint16 62 | pointer-ref-c-int16 63 | pointer-ref-c-uint32 64 | pointer-ref-c-int32 65 | pointer-ref-c-uint64 66 | pointer-ref-c-int64 67 | pointer-ref-c-unsigned-char 68 | pointer-ref-c-char 69 | pointer-ref-c-unsigned-short 70 | pointer-ref-c-short 71 | pointer-ref-c-unsigned-int 72 | pointer-ref-c-int 73 | pointer-ref-c-unsigned-long 74 | pointer-ref-c-long 75 | pointer-ref-c-float 76 | pointer-ref-c-double 77 | pointer-ref-c-pointer 78 | 79 | ;; pointer set 80 | pointer-set-c-uint8! 81 | pointer-set-c-int8! 82 | pointer-set-c-uint16! 83 | pointer-set-c-int16! 84 | pointer-set-c-uint32! 85 | pointer-set-c-int32! 86 | pointer-set-c-uint64! 87 | pointer-set-c-int64! 88 | pointer-set-c-unsigned-char! 89 | pointer-set-c-char! 90 | pointer-set-c-unsigned-short! 91 | pointer-set-c-short! 92 | pointer-set-c-unsigned-int! 93 | pointer-set-c-int! 94 | pointer-set-c-unsigned-long! 95 | pointer-set-c-long! 96 | pointer-set-c-float! 97 | pointer-set-c-double! 98 | pointer-set-c-pointer! 99 | 100 | ;; sizeof 101 | size-of-char 102 | size-of-short 103 | size-of-int 104 | size-of-long 105 | size-of-float 106 | size-of-double 107 | size-of-pointer 108 | size-of-int8_t 109 | size-of-int16_t 110 | size-of-int32_t 111 | size-of-int64_t 112 | 113 | pointer? 114 | bytevector->pointer 115 | pointer->bytevector 116 | pointer->integer 117 | integer->pointer 118 | 119 | ) 120 | (import (rnrs) 121 | (primitives ffi/dlopen ffi/dlsym 122 | ffi-attribute-core-entry 123 | ffi/ret-converter 124 | ffi/arg-converter 125 | ffi/convert-arg-descriptor 126 | ffi/convert-ret-descriptor 127 | ffi/make-callout 128 | ffi/make-callback 129 | ffi/apply 130 | ;; in lib/Base/std-ffi.sch 131 | ffi-get-abi 132 | ffi/rename-ret-type 133 | ffi/rename-arg-type 134 | void*-rt 135 | void*? 136 | void*->address 137 | sizeof:long 138 | sizeof:pointer 139 | %peek8 %peek8u 140 | %peek16 %peek16u 141 | %peek32 %peek32u 142 | %peek-long %peek-ulong 143 | peek-bytes 144 | poke-bytes 145 | void*-float-ref 146 | void*-double-ref 147 | void*-void*-ref 148 | void*-void*-set! 149 | ffi/handle->address 150 | make-nonrelocatable-bytevector 151 | )) 152 | 153 | ;; it might be better not to show handle (integer) itself 154 | (define-record-type shared-object 155 | (fields handle)) 156 | 157 | (define (open-shared-object path) 158 | (let ((handle (ffi/dlopen path))) 159 | (and handle 160 | (make-shared-object handle)))) 161 | 162 | (define-record-type ( make-pointer pointer?) 163 | (fields (immutable src pointer-src) 164 | ;; nonrelocatable bytevector 165 | dummy 166 | ;; element pointer of above 167 | (immutable ptr pointer-ptr))) 168 | (define (null-pointer? pointer) (zero? (pointer->integer pointer))) 169 | 170 | (define (void*->pointer v*) 171 | (let ((bv (make-bytevector size-of-pointer))) 172 | (if (= size-of-pointer 4) 173 | (bytevector-u32-native-set! bv 0 (void*-ptr v*)) 174 | (bytevector-u64-native-set! bv 0 (void*-ptr v*))) 175 | (make-pointer bv #f v*))) 176 | 177 | ;; we can't use unsigned->void*, this converts null pointer 178 | ;; to #f... 179 | (define make-void* (record-constructor void*-rt)) 180 | (define address->pointer 181 | (lambda (addr) 182 | (void*->pointer (make-void* addr)))) 183 | ;; ffi/dlsym returns integer (address) directly so 184 | ;; we need to get converter 185 | (define (lookup-shared-object lib name) 186 | (let ((address (ffi/dlsym (shared-object-handle lib) name))) 187 | (address->pointer address))) 188 | 189 | ;; we want to manage foreign procedure per shared object 190 | ;; so implement this here as well 191 | (define (pointer->void* t o) 192 | (define (convert o) 193 | (cond ((pointer? o) (pointer-ptr o)) 194 | ((bytevector? o) (convert (bytevector->pointer o))) 195 | ((string? o) (convert (string->utf8 (string-append o "\x0;")))) 196 | (else o))) 197 | (case t 198 | ((void*) (convert o)) 199 | (else o))) 200 | (define (%void*->pointer o) 201 | (if (void*? o) 202 | (void*->pointer o) 203 | o)) 204 | 205 | (define (sync-pointer arg) 206 | (if (and (pointer? arg) (not (null-pointer? arg))) 207 | (let* ((dst (pointer-src arg)) 208 | (len (bytevector-length dst))) 209 | (do ((i 0 (+ i 1))) 210 | ((= i len) arg) 211 | (bytevector-u8-set! dst i (pointer-ref-c-uint8 arg i)))) 212 | arg)) 213 | 214 | (define (make-foreign-invoker tramp args ret ret-conv arg-conv name arg-types) 215 | (lambda actual 216 | ;; (display name) (newline) (display actual) (newline) 217 | (let-values (((error? value) 218 | (ffi/apply tramp args ret 219 | (map (lambda (c v) (c v (symbol->string name))) 220 | arg-conv 221 | (map pointer->void* arg-types actual))))) 222 | (for-each sync-pointer actual) 223 | (if error? 224 | (error name "Failed to call foreign procedure" name actual) 225 | (sync-pointer (%void*->pointer (ret-conv value (symbol->string name)))))))) 226 | 227 | (define make-c-function 228 | ;; for some reason ffi-get-abi requires something for type 229 | ;; and if we pass null, we can get cdecl 230 | (let ((abi (ffi-get-abi 'callout '()))) 231 | (lambda (lib ret name arg-type) 232 | (let* ((rconv (ffi/ret-converter ret)) 233 | (argconv (map ffi/arg-converter arg-type)) 234 | (addr (ffi/dlsym (shared-object-handle lib) (symbol->string name))) 235 | (renamed-args (map ffi/rename-arg-type arg-type)) 236 | (renamed-ret (ffi/rename-ret-type ret)) 237 | (tramp (ffi/make-callout abi addr renamed-args renamed-ret)) 238 | (args (ffi/convert-arg-descriptor abi renamed-args)) 239 | (ret (ffi/convert-ret-descriptor abi renamed-ret))) 240 | (make-foreign-invoker tramp args ret rconv argconv name arg-type))))) 241 | 242 | ;; maybe we should make this GC protected 243 | (define make-c-callback 244 | (let ((abi (ffi-get-abi 'callback '()))) 245 | (lambda (ret types proc) 246 | (ffi/make-callback 247 | abi 248 | (lambda args 249 | (let ((v (apply proc (map (lambda (t v) 250 | (sync-pointer 251 | (%void*->pointer ((ffi/ret-converter t) v t)))) 252 | types args))) 253 | (r-conv (ffi/arg-converter ret))) 254 | ;; sync returning value 255 | (pointer->void* 256 | (sync-pointer 257 | (if r-conv 258 | (r-conv v ret) 259 | v))))) 260 | (map ffi/rename-arg-type types) 261 | (ffi/rename-ret-type ret))))) 262 | ;; dummy 263 | (define (free-c-callback ignore) #t) 264 | 265 | (define void*-ptr (record-accessor void*-rt 'ptr)) 266 | (define pointer-pointer 267 | (lambda (p) 268 | (void*-ptr (pointer-ptr p)))) 269 | (define-syntax define-pointer-ref 270 | (syntax-rules () 271 | ((_ name peek) 272 | (define (name p offset) 273 | (peek (+ (pointer-pointer p) offset)))))) 274 | 275 | (define-pointer-ref pointer-ref-c-uint8 %peek8u) 276 | (define-pointer-ref pointer-ref-c-int8 %peek8) 277 | (define-pointer-ref pointer-ref-c-uint16 %peek16u) 278 | (define-pointer-ref pointer-ref-c-int16 %peek16) 279 | (define-pointer-ref pointer-ref-c-uint32 %peek32u) 280 | (define-pointer-ref pointer-ref-c-int32 %peek32) 281 | (define (pointer-ref-c-uint64 p offset) 282 | (let* ((addr (pointer-pointer p)) 283 | (bv (make-bytevector 8))) 284 | (peek-bytes (+ addr offset) bv 8) 285 | (bytevector-u64-native-ref bv 0))) 286 | (define (pointer-ref-c-int64 p offset) 287 | (let* ((addr (pointer-pointer p)) 288 | (bv (make-bytevector 8))) 289 | (peek-bytes (+ addr offset) bv 8) 290 | (bytevector-s64-native-ref bv 0))) 291 | 292 | (define pointer-ref-c-unsigned-char pointer-ref-c-uint8) 293 | (define pointer-ref-c-char pointer-ref-c-int8) 294 | (define pointer-ref-c-unsigned-short pointer-ref-c-uint16) 295 | (define pointer-ref-c-short pointer-ref-c-int16) 296 | (define pointer-ref-c-unsigned-int pointer-ref-c-uint32) 297 | (define pointer-ref-c-int pointer-ref-c-int32) 298 | (define-pointer-ref pointer-ref-c-unsigned-long %peek-long) 299 | (define-pointer-ref pointer-ref-c-long %peek-ulong) 300 | ;; use predefined ones 301 | (define (pointer-ref-c-float p offset) 302 | (let ((p (pointer-ptr p))) 303 | (void*-float-ref p offset))) 304 | (define (pointer-ref-c-double p offset) 305 | (let ((p (pointer-ptr p))) 306 | (void*-double-ref p offset))) 307 | (define (pointer-ref-c-pointer p offset) 308 | (let ((p (pointer-ptr p))) 309 | (void*->pointer (void*-void*-ref p offset)))) 310 | 311 | ;; pointer set 312 | (define-syntax define-pointer-set 313 | (syntax-rules () 314 | ((_ name size bv-set) 315 | (define (name p offset val) 316 | (let ((bv (make-bytevector size))) 317 | (bv-set bv 0 val) 318 | (poke-bytes (+ (pointer-pointer p) offset) bv size)))))) 319 | 320 | (define (bytevector-long-native-set! bv index val) 321 | (if (= size-of-long 4) 322 | (bytevector-s32-ref bv index val (native-endianness)) 323 | (bytevector-s64-ref bv index val (native-endianness)))) 324 | (define (bytevector-ulong-native-set! bv index val) 325 | (if (= size-of-long 4) 326 | (bytevector-u32-ref bv index val (native-endianness)) 327 | (bytevector-u64-ref bv index val (native-endianness)))) 328 | 329 | (define-pointer-set pointer-set-c-uint8! 1 bytevector-u8-set!) 330 | (define-pointer-set pointer-set-c-int8! 1 bytevector-s8-set!) 331 | (define-pointer-set pointer-set-c-uint16! 2 bytevector-u16-native-set!) 332 | (define-pointer-set pointer-set-c-int16! 2 bytevector-s16-native-set!) 333 | (define-pointer-set pointer-set-c-uint32! 4 bytevector-u32-native-set!) 334 | (define-pointer-set pointer-set-c-int32! 4 bytevector-s32-native-set!) 335 | (define-pointer-set pointer-set-c-uint64! 8 bytevector-u64-native-set!) 336 | (define-pointer-set pointer-set-c-int64! 8 bytevector-s64-native-set!) 337 | (define pointer-set-c-unsigned-char! pointer-set-c-uint8!) 338 | (define pointer-set-c-char! pointer-set-c-int8!) 339 | (define pointer-set-c-unsigned-short! pointer-set-c-uint16!) 340 | (define pointer-set-c-short! pointer-set-c-int16!) 341 | (define pointer-set-c-unsigned-int! pointer-set-c-uint32!) 342 | (define pointer-set-c-int! pointer-set-c-int32!) 343 | (define-pointer-set pointer-set-c-unsigned-long! 344 | size-of-long bytevector-ulong-native-set!) 345 | (define-pointer-set pointer-set-c-long! 346 | size-of-long bytevector-long-native-set!) 347 | (define-pointer-set pointer-set-c-float! 4 bytevector-ieee-single-native-set!) 348 | (define-pointer-set pointer-set-c-double! 8 bytevector-ieee-double-native-set!) 349 | (define (pointer-set-c-pointer! p offset v) 350 | (let ((p (pointer-ptr p)) 351 | (v (pointer-ptr v))) 352 | (void*-void*-set! p offset v))) 353 | 354 | 355 | ;; types 356 | (define char 'char) ;; should we use byte? 357 | (define unsigned-char 'uchar) ;; should we use unsigned? 358 | (define short 'short) 359 | (define unsigned-short 'ushort) 360 | (define int 'int) 361 | (define unsigned-int 'uint) 362 | (define long 'long) 363 | (define unsigned-long 'ulong) 364 | (define float 'float) 365 | (define double 'double) 366 | (define int8_t 'byte) 367 | (define uint8_t 'unsigned) 368 | (define int16_t 'short) 369 | (define uint16_t 'ushort) 370 | (define int32_t 'int) 371 | (define uint32_t 'uint) 372 | (define int64_t 'longlong) 373 | (define uint64_t 'ulonglong) 374 | (define pointer 'void*) 375 | (define-syntax callback 376 | (syntax-rules () 377 | ((_ ignore ...) 'tramp))) 378 | (define void 'void) 379 | 380 | (define size-of-char 1) 381 | (define size-of-short 2) 382 | (define size-of-int 4) 383 | (define size-of-long sizeof:long) 384 | (define size-of-float 4) 385 | (define size-of-double 8) 386 | (define size-of-pointer sizeof:pointer) 387 | (define size-of-int8_t 1) 388 | (define size-of-int16_t 2) 389 | (define size-of-int32_t 4) 390 | (define size-of-int64_t 8) 391 | 392 | (define (bytevector->pointer bv . maybe-offset) 393 | ;; this is absolutely not documented anywhere and may not work 394 | ;; in future. in include/Sys/macros.h, bytevector-ref is 395 | ;; defined like this (*((byte*)(ptrof(x)+1)+i)) 396 | ;; thus, after 1 word, it will be the content of the bytevector. 397 | ;; so what we need to do here is adding offset of word. 398 | ;; we can actually calculate offset, but we don't do it for now 399 | (let ((dummy (make-nonrelocatable-bytevector (bytevector-length bv)))) 400 | (bytevector-copy! bv 0 dummy 0 (bytevector-length bv)) 401 | (make-pointer bv dummy (make-void* (+ (ffi/handle->address dummy) size-of-pointer))))) 402 | (define (pointer->bytevector p len . maybe-offset) 403 | ;; Unfortunately, we only have one way, copy 404 | (let ((bv (make-bytevector len))) 405 | (do ((i 0 (+ i 1))) 406 | ((= i len) bv) 407 | (bytevector-u8-set! bv i (pointer-ref-c-uint8 p i))))) 408 | 409 | (define integer->pointer address->pointer) 410 | (define (pointer->integer p) 411 | (void*->address (pointer-ptr p))) 412 | 413 | ) 414 | -------------------------------------------------------------------------------- /tests/test.scm: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import (rnrs) 3 | (rnrs eval) 4 | (pffi) 5 | (srfi :64)) 6 | 7 | (test-begin "PFFI") 8 | 9 | (define test-lib (open-shared-object "./functions.so")) 10 | 11 | (define-type-alias ppp pointer) 12 | 13 | ;; (define (print . args) 14 | ;; (for-each display args) (newline) 15 | ;; (flush-output-port (current-output-port))) 16 | 17 | ;; there is no particular type for this, yet 18 | ;; TODO should we make 'shared-object?' or so? 19 | (test-assert "shared object" test-lib) 20 | 21 | ;; TODO should we make 'foreign-procedure?' or so? 22 | ;; or can we assume it's always a procedure in any case? 23 | (test-assert "foreign-procedure" 24 | (foreign-procedure test-lib int plus (int int))) 25 | (test-equal "plus" 2 26 | ((foreign-procedure test-lib int plus (int int)) 1 1)) 27 | 28 | (test-assert "null-pointer? (1)" (null-pointer? (integer->pointer 0))) 29 | (test-assert "null-pointer? (2)" (not (null-pointer? (integer->pointer 1)))) 30 | (test-error (null-pointer? 'not-a-pointer)) 31 | 32 | (let ((proc (c-callback int ((int i)) (lambda (i) (* i i))))) 33 | (define callback-proc 34 | (foreign-procedure test-lib int callback_proc ((callback int (int)) int))) 35 | (test-equal "callback" 4 (callback-proc proc 2)) 36 | (test-assert "free" (free-c-callback proc))) 37 | 38 | (let ((proc (c-callback int ((pointer p)) 39 | (lambda (p) (pointer-ref-c-int32 p 0))))) 40 | (define callback-proc 41 | (foreign-procedure test-lib int callback_proc2 42 | ((callback int (pointer)) int))) 43 | (test-equal "callback (2)" 2 (callback-proc proc 2)) 44 | (test-assert "free" (free-c-callback proc))) 45 | 46 | (let ((proc (c-callback pointer ((pointer p)) (lambda (p) p)))) 47 | (define callback-proc 48 | (foreign-procedure test-lib pointer callback_proc3 49 | ((callback pointer (pointer)) int))) 50 | (test-assert "callback (3)" (pointer? (callback-proc proc 2))) 51 | (test-assert "free" (free-c-callback proc))) 52 | 53 | (let () 54 | (define-foreign-variable test-lib int externed_variable) 55 | (test-equal "foreign-variable" 10 externed-variable) 56 | (test-assert "set! foreign-variable" (set! externed-variable 11)) 57 | (test-equal "foreign-variable (2)" 11 externed-variable) 58 | (test-equal "foreign-variable (3)" 11 59 | ((foreign-procedure test-lib int get_externed_variable ())))) 60 | 61 | (let ((bv (make-bytevector (* 4 5) 0))) 62 | (test-assert "calling with bytevector->pointer" 63 | ((foreign-procedure test-lib void fill_one (pointer int)) 64 | (bytevector->pointer bv) 5)) 65 | (test-equal "passing bytevector" 66 | '(1 1 1 1 1) (bytevector->uint-list bv (native-endianness) 4))) 67 | 68 | (test-equal "size-of-char" 1 size-of-char) 69 | (test-equal "size-of-short" 2 size-of-short) 70 | (test-equal "size-of-int" 4 size-of-int) 71 | (test-assert "size-of-long" (memv size-of-long '(4 8))) 72 | (test-assert "size-of-pointer" (memv size-of-pointer '(4 8))) 73 | ;; I think we can assume this 74 | (test-equal "size-of-float" 4 size-of-float) 75 | (test-equal "size-of-double" 8 size-of-double) 76 | (test-equal "size-of-int8_t" 1 size-of-int8_t) 77 | (test-equal "size-of-int16_t" 2 size-of-int16_t) 78 | (test-equal "size-of-int32_t" 4 size-of-int32_t) 79 | (test-equal "size-of-int64_t" 8 size-of-int64_t) 80 | 81 | ;; pointer operations 82 | (let* ((bv (u8-list->bytevector '(0 1 2 3 4 5 6 7 8 9 0))) 83 | (p (bytevector->pointer bv))) 84 | ;; for convenience 85 | (define (bytevector-u8-ref/endian bv index endian) 86 | (bytevector-u8-ref bv index)) 87 | (define (bytevector-u8-set/endian! bv index v endian) 88 | (bytevector-u8-set! bv v index)) 89 | (define (bytevector-s8-ref/endian bv index endian) 90 | (bytevector-s8-ref bv index)) 91 | (define (bytevector-s8-set/endian! bv index v endian) 92 | (bytevector-s8-set! bv v index)) 93 | 94 | (define-syntax test-pointer-ref 95 | (syntax-rules () 96 | ((_ p-ref bv-ref) 97 | (test-equal 'p-ref (bv-ref bv 1 (native-endianness)) (p-ref p 1))))) 98 | 99 | (define-syntax test-pointer-set! 100 | (lambda (x) 101 | (define (->names type) 102 | (let ((s (symbol->string (syntax->datum type)))) 103 | (list (string->symbol (string-append "pointer-ref-c-" s)) 104 | (string->symbol (string-append "pointer-set-c-" s "!"))))) 105 | (syntax-case x () 106 | ((k type value) 107 | (with-syntax (((ref set) (datum->syntax #'k (->names #'type)))) 108 | #'(begin 109 | (test-equal 'set value 110 | (let* ((t (bytevector-copy bv)) 111 | (p (bytevector->pointer t))) 112 | (set p 1 value) 113 | (ref p 1))))))))) 114 | (test-assert "pointer?" (pointer? p)) 115 | (test-pointer-ref pointer-ref-c-int8 bytevector-s8-ref/endian) 116 | (test-pointer-ref pointer-ref-c-uint8 bytevector-u8-ref/endian) 117 | (test-pointer-ref pointer-ref-c-int16 bytevector-s16-ref) 118 | (test-pointer-ref pointer-ref-c-uint16 bytevector-u16-ref) 119 | (test-pointer-ref pointer-ref-c-int32 bytevector-s32-ref) 120 | (test-pointer-ref pointer-ref-c-uint32 bytevector-u32-ref) 121 | (test-pointer-ref pointer-ref-c-int64 bytevector-s64-ref) 122 | (test-pointer-ref pointer-ref-c-uint64 bytevector-u64-ref) 123 | (test-pointer-ref pointer-ref-c-float bytevector-ieee-single-ref) 124 | (test-pointer-ref pointer-ref-c-double bytevector-ieee-double-ref) 125 | (test-equal "pointer-ref-c-pointer" 126 | (if (= size-of-pointer 8) 127 | (bytevector-u64-ref bv 1 (native-endianness)) 128 | (bytevector-u32-ref bv 1 (native-endianness))) 129 | (pointer->integer (pointer-ref-c-pointer p 1))) 130 | 131 | ;; sets 132 | (test-pointer-set! int8 -128) 133 | (test-pointer-set! int8 127) 134 | (test-pointer-set! uint8 0) 135 | (test-pointer-set! uint8 255) 136 | (test-pointer-set! int16 #x-8000) 137 | (test-pointer-set! int16 #x7FFF) 138 | (test-pointer-set! uint16 0) 139 | (test-pointer-set! uint16 #xFFFF) 140 | (test-pointer-set! int32 #x-80000000) 141 | (test-pointer-set! int32 #x7FFFFFFF) 142 | (test-pointer-set! uint32 0) 143 | (test-pointer-set! uint32 #xFFFFFFFF) 144 | ;; lazy... 145 | (test-pointer-set! int64 #x-80000000) 146 | (test-pointer-set! int64 #x7FFFFFFF) 147 | (test-pointer-set! uint64 0) 148 | (test-pointer-set! uint64 #xFFFFFFFF) 149 | (test-pointer-set! float 1.0) 150 | (test-pointer-set! double 1.0) 151 | (test-equal 'pointer-set-c-pointer! 12345 152 | (let* ((t (bytevector-copy bv)) 153 | (p (bytevector->pointer t))) 154 | (pointer-set-c-pointer! p 1 (integer->pointer 12345)) 155 | (pointer->integer (pointer-ref-c-pointer p 1)))) 156 | ) 157 | 158 | ;; struct field 159 | (let () 160 | (define-foreign-struct st-parent 161 | (fields (int count) 162 | (pointer elements))) 163 | (define-foreign-struct st-child 164 | (fields ((struct st-parent) p) 165 | (short attr))) 166 | (test-assert "struct ctr (0)" (make-st-child (make-st-parent 167 | 0 (integer->pointer 0)) 0)) 168 | (let ((st (make-st-child (make-st-parent 0 (integer->pointer 0)) 0))) 169 | (define (check-elements p) 170 | (do ((i 0 (+ i 1))) ((= i 10) #t) 171 | (test-equal (string-append "element (" (number->string i) ")") 172 | i (pointer-ref-c-int32 p (* i size-of-int32_t))))) 173 | (test-assert "predicate (child)" (st-child? st)) 174 | (test-assert "predicate (parent)" (st-parent? st)) 175 | (test-assert "predicate (bv)" (bytevector? st)) 176 | (test-equal "size" size-of-st-child (bytevector-length st)) 177 | ((foreign-procedure test-lib void fill_st_values (pointer)) 178 | (bytevector->pointer st)) 179 | (test-equal "count" 10 (st-parent-count st)) 180 | (test-assert "elements" (st-parent-elements st)) 181 | (check-elements (st-parent-elements st)) 182 | (let ((parent (st-child-p st))) 183 | (check-elements (st-parent-elements parent))) 184 | (test-equal "attr" 5 (st-child-attr st)) 185 | ((foreign-procedure test-lib void free_st_values (pointer)) 186 | (bytevector->pointer st)))) 187 | 188 | ;; parent 189 | (let () 190 | (define-foreign-struct st-parent 191 | (fields (int count) 192 | (pointer elements))) 193 | (define-foreign-struct st-child 194 | (fields (short attr)) 195 | (parent st-parent)) 196 | (test-assert "struct ctr (1)" (make-st-child 0 (integer->pointer 0) 0)) 197 | (let ((st (make-st-child 0 (integer->pointer 0) 0))) 198 | (test-assert "predicate (child)" (st-child? st)) 199 | (test-assert "predicate (parent)" (st-parent? st)) 200 | (test-assert "predicate (bv)" (bytevector? st)) 201 | (test-equal "size" size-of-st-child (bytevector-length st)) 202 | ((foreign-procedure test-lib void fill_st_values (pointer)) 203 | (bytevector->pointer st)) 204 | (test-equal "count" 10 (st-parent-count st)) 205 | (test-assert "elements" (st-parent-elements st)) 206 | (let ((p (st-parent-elements st))) 207 | (do ((i 0 (+ i 1))) ((= i 10) #t) 208 | (test-equal (string-append "element (" (number->string i) ")") 209 | i (pointer-ref-c-int32 p (* i size-of-int32_t))))) 210 | (test-equal "attr" 5 (st-child-attr st)) 211 | ((foreign-procedure test-lib void free_st_values (pointer)) 212 | (bytevector->pointer st)))) 213 | 214 | ;; protocol thing 215 | (let () 216 | (define-foreign-struct st-parent 217 | (fields (int count) 218 | (pointer elements)) 219 | (protocol 220 | (lambda (p) 221 | (lambda (size) 222 | (p size (integer->pointer 0)))))) 223 | (define-foreign-struct st-child 224 | (fields (short attr)) 225 | (parent st-parent) 226 | (protocol 227 | (lambda (n) 228 | (lambda (size attr) 229 | ((n size) attr))))) 230 | (test-assert "struct ctr" (make-st-child 0 0)) 231 | (let ((st (make-st-child 5 10))) 232 | (test-assert "predicate (child)" (st-child? st)) 233 | (test-assert "predicate (parent)" (st-parent? st)) 234 | (test-assert "predicate (bv)" (bytevector? st)) 235 | (test-equal "parent-slot" 5 (st-parent-count st)) 236 | (test-equal "this-slot" 10 (st-child-attr st)) 237 | )) 238 | 239 | ;; passing string or bytevector to pointer type 240 | (let ((id-str (foreign-procedure test-lib pointer id_str (pointer)))) 241 | (test-equal "id-str (1)" 242 | (string->utf8 "foo") (pointer->bytevector (id-str "foo") 3)) 243 | (test-equal "id-str (2)" 244 | #vu8(1 2 3) (pointer->bytevector (id-str #vu8(1 2 3)) 3))) 245 | 246 | ;; union 247 | (let () 248 | (define-foreign-struct a-st 249 | (fields (short s1) 250 | (short s2))) 251 | (define-foreign-union a-union 252 | (fields (int i) ;; 4 253 | (pointer p) ;; 4 or 8 254 | ((struct a-st) st))) 255 | (test-equal "union size (1)" size-of-pointer size-of-a-union) 256 | (let ((bv (make-a-union))) 257 | (test-assert "a-union? (1)" (a-union? bv)) 258 | (test-assert "a-union-i-set (1)" (a-union-i-set! bv 1)) 259 | (test-equal "a-union-p (1)" 1 (pointer->integer (a-union-p bv))) 260 | 261 | (test-equal "a-st-s1 (1)" 1 (a-st-s1 (a-union-st bv))) 262 | (test-equal "a-st-s2 (1)" 0 (a-st-s2 (a-union-st bv))))) 263 | 264 | ;; Next offset computation was incorrect. 265 | (let () 266 | (define-foreign-struct WIN-BORDER 267 | (fields (int ls) 268 | (int rs) 269 | (int ts) 270 | (int bs) 271 | (int tl) 272 | (int tr) 273 | (int bl) 274 | (int br))) 275 | (define-foreign-struct WIN 276 | (fields (int startx) 277 | (int starty) 278 | (int height) 279 | (int width) 280 | ((struct WIN-BORDER) border))) 281 | (define c char->integer) 282 | 283 | (test-equal (* 8 size-of-int) size-of-WIN-BORDER) 284 | (test-equal (+ (* 4 size-of-int) size-of-WIN-BORDER) 285 | size-of-WIN) 286 | (let ((border (make-WIN-BORDER (c #\|) (c #\|) (c #\-) (c #\-) 287 | (c #\+) (c #\+) (c #\+) (c #\+))) 288 | (height 3) 289 | (width 10)) 290 | (test-assert (make-WIN height width 0 0 border)))) 291 | 292 | 293 | (let () 294 | (define-foreign-struct a-st 295 | (fields (short s1) 296 | (short s2))) 297 | (define-foreign-union a-union 298 | (fields (int i) ;; 4 299 | (pointer p) ;; 4 or 8 300 | ((struct a-st) st)) 301 | (protocol (lambda (p) 302 | (lambda (i) 303 | (p 'i i))))) 304 | (test-equal "union size (2)" size-of-pointer size-of-a-union) 305 | (let ((bv (make-a-union 2))) 306 | (test-assert "a-union? (2)" (a-union? bv)) 307 | ;;(test-assert "a-union-i-set" (a-union-i-set! bv 1)) 308 | (test-equal "a-union-p (2)" 2 (pointer->integer (a-union-p bv))) 309 | 310 | (test-equal "a-st-s1 (2)" 2 (a-st-s1 (a-union-st bv))) 311 | (test-equal "a-st-s2 (2)" 0 (a-st-s2 (a-union-st bv))))) 312 | 313 | (let () 314 | (test-error "field is not a symbol" 315 | syntax-violation? 316 | (eval '(define-foreign-struct a 317 | (fields ((callback double (double pointer)) function))) 318 | (environment '(pffi)))) 319 | (test-error "field is not a symbol (union)" 320 | syntax-violation? 321 | (eval '(define-foreign-union b 322 | (fields ((callback double (double pointer)) function))) 323 | (environment '(pffi))))) 324 | 325 | ;; varargs 326 | (let ((sum (foreign-procedure test-lib int sum (int ___)))) 327 | (test-equal "variadic argument (1)" 10 (sum 4 1 2 3 4)) 328 | ;; #t = 1 :) 329 | (test-equal "variadic argument (2)" 10 (sum 4 #t 2 3 4))) 330 | 331 | ;; typedef 332 | (let ((id-str (foreign-procedure test-lib ppp id_str (ppp)))) 333 | (test-equal "id-str (1)" 334 | (string->utf8 "foo") (pointer->bytevector (id-str "foo") 3)) 335 | (test-equal "id-str (2)" 336 | #vu8(1 2 3) (pointer->bytevector (id-str #vu8(1 2 3)) 3))) 337 | 338 | (let () 339 | (define-foreign-struct st-ppp 340 | (fields (ppp p))) 341 | (define-foreign-struct un-ppp 342 | (fields (ppp p))) 343 | (test-assert "make-st-ppp" (make-st-ppp (integer->pointer 0))) 344 | (test-assert "make-un-ppp" (make-un-ppp (integer->pointer 0)))) 345 | 346 | ;; boolean type 347 | (let ((is-even? (foreign-procedure test-lib boolean is_even (int))) 348 | (check-dispatch 349 | (foreign-procedure test-lib boolean check_dispatch (int boolean)))) 350 | ;; (display size-of-boolean) 351 | ;; We don't check the size of boolean here, as some use C99 bool 352 | ;; and some, or Chez..., use just int 353 | (test-assert "size-of-boolean" size-of-boolean) 354 | (test-assert "is-even? (1)" (boolean? (is-even? 2))) 355 | (test-assert "is-even? (2)" (not (is-even? 1))) 356 | (test-assert "check-dispatch (1)" (check-dispatch 2 #t)) 357 | (test-assert "check-dispatch (2)" (not (check-dispatch 2 #f)))) 358 | 359 | (let () 360 | (define-type-alias my-int int) 361 | (define-foreign-variable test-lib (array my-int) int_array) 362 | (define get-int-array (foreign-procedure test-lib pointer get_int_array ())) 363 | (test-assert (pointer? int-array)) 364 | (test-equal 1 (int-array 0)) 365 | (test-equal 2 (int-array 1)) 366 | (set! int-array (0 100)) 367 | (test-equal 100 (int-array 0)) 368 | (let ((raw (get-int-array))) 369 | (test-equal 100 (pointer-ref-c-int raw 0)))) 370 | 371 | (let () 372 | (define-foreign-struct st-parent 373 | (fields (int count) 374 | (pointer elements))) 375 | (define-foreign-struct st-child 376 | (fields ((struct st-parent) p) 377 | (short attr))) 378 | (define-type-alias p-st (* st-child)) 379 | (let ((st (make-st-child (make-st-parent 0 (integer->pointer 0)) 0))) 380 | ((foreign-procedure test-lib void fill_st_values (p-st)) 381 | (bytevector->pointer st)) 382 | (test-equal "count p-st" 10 (st-parent-count st)))) 383 | 384 | 385 | ;; empty struct 386 | (let () 387 | (define-foreign-struct ok) 388 | (test-equal "size of empty struct" 0 size-of-ok)) 389 | 390 | ;; pointer variable 391 | (let () 392 | (define-foreign-variable test-lib (* int) int_pointer) 393 | 394 | (let ((value ((foreign-procedure test-lib int initial_int_pointer_value ())))) 395 | (test-assert "pointer value" (pointer? int-pointer)) 396 | (test-assert "pointer vs actual value (1)" (not (equal? value int-pointer))) 397 | 398 | (test-equal "pointer value (1)" value (pointer-ref-c-int int-pointer 0)))) 399 | 400 | ;; wchar 401 | (let* ((bv (make-bytevector size-of-wchar 0)) 402 | (p (bytevector->pointer bv))) 403 | (define wtoupper (foreign-procedure test-lib wchar wtoupper (wchar))) 404 | (define wcallback 405 | (foreign-procedure test-lib wchar wcallback (wchar (callback wchar (wchar))))) 406 | (test-assert "wchar set" (pointer-set-c-wchar! p 0 #\a)) 407 | (test-equal "wchar ref" #\a (pointer-ref-c-wchar p 0)) 408 | (test-equal "wtoupper" #\A (wtoupper #\a)) 409 | 410 | (let ((callback (c-callback wchar ((wchar wc)) 411 | (lambda (wc) (char-upcase wc))))) 412 | (test-equal "wcallback" #\A (wcallback #\a callback)))) 413 | 414 | ;; (define-syntax test-string-argument 415 | ;; (syntax-rules () 416 | ;; ((_ type name) 417 | ;; (let () 418 | ;; (define proc 419 | ;; (foreign-procedure test-lib type name (type (callback type (type))))) 420 | ;; (define cb (c-callback type (type) string-upcase)) 421 | ;; (test-equal "AA" (proc "aa" cb)))))) 422 | ;; ;; char* 423 | ;; (test-string-argument char* str_cb) 424 | ;; (test-string-argument wchar* wstr_cb) 425 | 426 | ;; For guile... 427 | (define failed (test-runner-fail-count (test-runner-current))) 428 | (test-end) 429 | 430 | (exit failed) 431 | --------------------------------------------------------------------------------