From 14682116298c90e495e059992d259fbe2a18a835 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 21 Apr 2024 12:40:12 +0300 Subject: [PATCH] Migrated from sourcehut --- .gitignore | 1 + Makefile | 2 + README.md | 4 + composition.scm | 7 + retropikzel/pffi/v0.1.0/main.scm | 416 +++++++++++++++++++++++++++++++ test/sdl2.scm | 32 +++ 6 files changed, 462 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 README.md create mode 100644 composition.scm create mode 100644 retropikzel/pffi/v0.1.0/main.scm create mode 100644 test/sdl2.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1377554 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*.swp diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..2104ac3 --- /dev/null +++ b/Makefile @@ -0,0 +1,2 @@ +test-sagittatius-sdl2: + sash -r7 -L . test/sdl2.scm diff --git a/README.md b/README.md new file mode 100644 index 0000000..7476dcd --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# Portable Foreign Function Interface for R7RS schemes + +Currently supported implementations +* Sagittarius [https://bitbucket.org/ktakashi/sagittarius-scheme/wiki/Home] diff --git a/composition.scm b/composition.scm new file mode 100644 index 0000000..dbd426f --- /dev/null +++ b/composition.scm @@ -0,0 +1,7 @@ +((packager . "retropikzel") + (name . "pffi") + (version . "v0.1.0") + (type . "library") + (description . "Portable Foreign Function Interface for R7RS schemes") + (license . "LGPL") + (dependencies ())) diff --git a/retropikzel/pffi/v0.1.0/main.scm b/retropikzel/pffi/v0.1.0/main.scm new file mode 100644 index 0000000..67f6a55 --- /dev/null +++ b/retropikzel/pffi/v0.1.0/main.scm @@ -0,0 +1,416 @@ +(define-library + (retropikzel pffi v0.1.0 main) + (cond-expand + (sagittarius + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (sagittarius ffi) + (sagittarius))) + (else (error "Implementation not supported by r7rs-pffi"))) + (export pffi-call + pffi-types + pffi-type-sizes + pffi-size-of + pffi-pointer-allocate + pffi-string->pointer + pffi-pointer->string + pffi-pointer-free + pffi-pointer? + pffi-pointer-null? + pffi-pointer-address-get + pffi-shared-object-load + pffi-shared-object-auto-load + pffi-pointer-set! + pffi-pointer-get + pffi-struct-make + pffi-struct-get + pffi-struct-set! + pffi-struct-pointer-get + pffi-struct-member-types-get + pffi-struct-pretty-print) + (begin + + (define library-version "v0.1.0") + + (define-record-type pffi-struct + (make-pffi-struct member-types member-names struct-alignment struct-pointer size) + pffi-struct? + (member-types pffi-struct-member-types-get) + (member-names pffi-struct-member-names-get) + (struct-alignment pffi-struct-alignment-get) + (struct-pointer pffi-struct-pointer-get) + (size pffi-struct-size-get)) + + (define pffi-types + '(int8 + uint8 + int16 + uint16 + int32 + uint32 + int64 + uint64 + intptr + uintptr + char + unsigned-char + short + unsigned-short + int + unsigned-int + long + unsigned-long + float + double + pointer)) + + (define string-split + (lambda (str mark) + (let* ((str-l (string->list str)) + (res (list)) + (last-index 0) + (index 0) + (splitter (lambda (c) + (cond ((char=? c mark) + (begin + (set! res (append res (list (string-copy str last-index index)))) + (set! last-index (+ index 1)))) + ((equal? (length str-l) (+ index 1)) + (set! res (append res (list (string-copy str last-index (+ index 1))))))) + (set! index (+ index 1))))) + (for-each splitter str-l) + res))) + + (define pffi-pointer-adress-get + (lambda (pointer) + (cond-expand (sagittarius (address pointer))))) + + (define auto-load-paths + (append + (cond-expand + (windows + (append + (if (get-environment-variable "SYSTEM") + (list (get-environment-variable "SYSTEM")) + (list)) + (if (get-environment-variable "WINDIR") + (list (get-environment-variable "WINDIR")) + (list)) + (list ".") + (string-split (get-environment-variable "PATH") #\;))) + (else + (append + (list (if (get-environment-variable "GUIX_ENVIRONMENT") + (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib") + "")) + (if (get-environment-variable "LD_LOAD_PATH") + (list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:) + (list)) + (list "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib")))))) + + + + (define platform-file-extension (cond-expand (windows ".dll") (else ".so"))) + + (define memorysession #f) + (define linker #f) + (define symbol-lookup #f) + (define kebab-case->snake-case + (lambda (str) (string-map (lambda (c) (if (char=? c #\-) #\_ c)) str))) + + (define pffi-type->native-type + (lambda (type) + (cond-expand + (sagittarius + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'intptr) 'intptr_t) + ((equal? type 'uintptr) 'uintptr_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'void*) + ((equal? type 'void) 'void) + (else (error "pffi-type->native-type -- No such pffi type" type))))))) + + (define pffi-pointer? + (lambda (object) + (cond-expand (sagittarius (pointer? object))))) + + (define pffi->native + (lambda (value) + (cond ((pffi-pointer? value) value) + ((pffi-struct? value) (pffi-struct-pointer-get value)) + (else value)))) + + (define pffi-call + (lambda (shared-object name type arguments) + (let ((types (map pffi-type->native-type (map car arguments))) + (vals (map pffi->native (map cdr arguments)))) + (cond-expand + (sagittarius + (apply (make-c-function shared-object + (pffi-type->native-type type) + name + types) vals)))))) + + (define pffi-type-sizes + (map + (lambda (type) + (cond + ((eq? type 'int8) (cond-expand (sagittarius size-of-int8_t))) + ((eq? type 'uint8) (cond-expand (sagittarius size-of-uint8_t))) + ((eq? type 'int16) (cond-expand (sagittarius size-of-int16_t))) + ((eq? type 'uint16) (cond-expand (sagittarius size-of-uint16_t))) + ((eq? type 'int32) (cond-expand (sagittarius size-of-int32_t))) + ((eq? type 'uint32) (cond-expand (sagittarius size-of-uint32_t))) + ((eq? type 'int64) (cond-expand (sagittarius size-of-int64_t))) + ((eq? type 'uint64) (cond-expand (sagittarius size-of-uint64_t))) + ((eq? type 'intptr) (cond-expand (sagittarius size-of-intptr_t))) + ((eq? type 'uintptr) (cond-expand (sagittarius size-of-uintptr_t))) + ((eq? type 'char) (cond-expand (sagittarius size-of-char))) + ((eq? type 'unsigned-char) (cond-expand (sagittarius size-of-char))) + ((eq? type 'short) (cond-expand (sagittarius size-of-short))) + ((eq? type 'unsigned-short) (cond-expand (sagittarius size-of-unsigned-short))) + ((eq? type 'int) (cond-expand (sagittarius size-of-int))) + ((eq? type 'unsigned-int) (cond-expand (sagittarius size-of-unsigned-int))) + ((eq? type 'long) (cond-expand (sagittarius size-of-long))) + ((eq? type 'unsigned-long) (cond-expand (sagittarius size-of-unsigned-long))) + ((eq? type 'float) (cond-expand (sagittarius size-of-float))) + ((eq? type 'double) (cond-expand (sagittarius size-of-double))) + ((eq? type 'pointer) (cond-expand (sagittarius size-of-void*))))) + pffi-types)) + + (define pffi-size-of + (lambda (type) + (let ((size (cdr (assoc type pffi-type-sizes)))) + size))) + + (define pffi-pointer-allocate + (lambda (size) + (cond-expand + (sagittarius (allocate-pointer size))))) + + (define pffi-string->pointer + (lambda (string-content) + (cond-expand (sagittarius (bytevector->pointer (string->utf8 string-content)))))) + + (define pffi-pointer->string + (lambda (pointer) + (cond-expand (sagittarius (utf8->string (pointer->bytevector pointer)))))) + + (define pffi-shared-object-load + (lambda (path) + (cond-expand (sagittarius (open-shared-library path))))) + + (define pffi-shared-object-auto-load + (lambda (object-name . additional-paths) + (let* ((paths (append auto-load-paths additional-paths)) + (shared-object #f)) + (for-each + (lambda (path) + (if (not shared-object) + (let ((object-path (string-append path + "/" + object-name + (cond-expand (windows ".dll") (else ".so")))) + (object-version-path (string-append path + "/" + object-name + (cond-expand (windows ".dll") (else ".so.0")))) + (object-lib-path (string-append path + "/" + (cond-expand (windows "") (else "lib")) + object-name + (cond-expand (windows ".dll") (else ".so")))) + (object-version-lib-path (string-append path + "/" + (cond-expand (windows "") (else "lib")) + object-name + (cond-expand (windows ".dll") (else ".so.0"))))) + (cond + ((file-exists? object-path) + (set! shared-object (pffi-shared-object-load object-path))) + ((file-exists? object-version-path) + (set! shared-object (pffi-shared-object-load object-version-path))) + ((file-exists? object-lib-path) + (set! shared-object (pffi-shared-object-load object-lib-path))) + ((file-exists? object-version-lib-path) + (set! shared-object (pffi-shared-object-load object-version-lib-path))))))) + paths) + (if (not shared-object) + (error (string-append "Could not load shared object: " object-name)) + shared-object)))) + + (define pffi-pointer-free + (lambda (pffi) + (cond-expand (sagittarius (c-free pointer))))) + + (define pffi-pointer-null? + (lambda (pointer) + (cond-expand (sagittarius (null-pointer? pointer))))) + + (define pffi-pointer-set! + (lambda (pointer type value offset) + (cond-expand + (sagittarius + (let ((p (integer->pointer (pffi-pointer-address-get pointer)))) + (cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value)) + ((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value)) + ((equal? type 'int16) (pointer-set-c-int16_t! p offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! p offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! p offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value)) + ((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value)) + ((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value)) + ((equal? type 'char) (pointer-set-c-char! p offset value)) + ((equal? type 'short) (pointer-set-c-short! p offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value)) + ((equal? type 'int) (pointer-set-c-int! p offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value)) + ((equal? type 'long) (pointer-set-c-long! p offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value)) + ((equal? type 'float) (pointer-set-c-float! p offset value)) + ((equal? type 'double) (pointer-set-c-double! p offset value)) + ((equal? type 'void) (pointer-set-c-void*! p offset value)))))))) + + (define pffi-pointer-get + (lambda (pointer type offset) + (cond-expand + (sagittarius + (let ((p (integer->pointer (pffi-pointer-address-get pointer))) + (native-type (pffi-type->native-type type))) + (cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset)) + ((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset)) + ((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset)) + ((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset)) + ((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset)) + ((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset)) + ((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset)) + ((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset)) + ((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset)) + ((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset)) + ((equal? native-type 'char) (pointer-ref-c-char p offset)) + ((equal? native-type 'short) (pointer-set-c-short p offset value)) + ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset)) + ((equal? native-type 'int) (pointer-ref-c-int p offset)) + ((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset)) + ((equal? native-type 'long) (pointer-ref-c-long p offset)) + ((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-long p offset)) + ((equal? native-type 'float) (pointer-ref-c-float p offset)) + ((equal? native-type 'double) (pointer-ref-c-double p offset)) + ((equal? native-type 'void*) (pointer-ref-c-void* p offset)))))))) + + (define largest-type-size + (lambda (types) + (let ((largest 0)) + (for-each + (lambda (type) + (if (> (pffi-size-of type) largest) + (set! largest (pffi-size-of type)))) + types) + largest))) + + (define figure-out-alignment + (lambda (member-types) + (largest-type-size member-types))) + + (define struct-members-size + (lambda (members) + (apply + (map pffi-size-of members)))) + + (define pffi-struct-make + (lambda (member-types member-names member-values) + (let* ((offset 0) + (alignment (figure-out-alignment member-types)) + (size (* alignment (length member-types))) + (struct-pointer (pffi-pointer-allocate size))) + (for-each + (lambda (type name value) + (pffi-pointer-set! struct-pointer type value offset) + (set! offset (+ offset alignment))) + member-types + member-names + member-values) + (make-pffi-struct member-types member-names alignment struct-pointer size)))) + + (define get-item-index + (lambda (item items) + (- (length (member item (reverse items))) 1))) + + (define get-member-type + (lambda (member-name member-names member-types) + (list-ref member-types (get-item-index member-name member-names)))) + + (define pffi-struct-get + (lambda (pffi-struct member-name) + (letrec* ((member-names (pffi-struct-member-names-get pffi-struct)) + (member-types (pffi-struct-member-types-get pffi-struct)) + (alignment (pffi-struct-alignment-get pffi-struct)) + (member-type (get-member-type member-name member-names member-types)) + (member-offset (* alignment (get-item-index member-name member-names)))) + (pffi-pointer-get (pffi-struct-pointer-get pffi-struct) + member-type + member-offset)))) + + (define pffi-struct-set! + (lambda (pffi-struct member-name value) + (letrec* + ((member-names (pffi-struct-member-names-get pffi-struct)) + (member-types (pffi-struct-member-types-get pffi-struct)) + (member-type (get-member-type member-name member-names member-types)) + (alignment (pffi-struct-alignment-get pffi-struct)) + (member-offset (* alignment (get-item-index member-name member-names)))) + (pffi-pointer-set! (pffi-struct-pointer-get pffi-struct) + member-type + value + member-offset)))) + + (define pffi-struct-pretty-print + (lambda (pffi-struct) + (display "Member types: ") + (display (pffi-struct-member-types-get pffi-struct)) + (newline) + (display "Member names: ") + (display (pffi-struct-member-names-get pffi-struct)) + (newline) + (display "Alignment: ") + (display (pffi-struct-alignment-get pffi-struct)) + (newline) + (display "Pointer: ") + (display (pffi-struct-pointer-get pffi-struct)) + (newline) + (display "Size: ") + (display (pffi-struct-size-get pffi-struct)) + (newline) + (display "Values: ") + (newline) + (for-each + (lambda (member-name) + (display " ") + (display member-name) + (display ": ") + (display (pffi-struct-get pffi-struct member-name)) + (newline)) + (pffi-struct-member-names-get pffi-struct)))) + + )) diff --git a/test/sdl2.scm b/test/sdl2.scm new file mode 100644 index 0000000..9d89e8b --- /dev/null +++ b/test/sdl2.scm @@ -0,0 +1,32 @@ +(import (scheme base) + (scheme write) + (scheme read) + (retropikzel pffi v0-1-0 main)) + + +(define sdl2 (pffi-shared-object-auto-load "SDL2" (list))) + +(pffi-call sdl2 'SDL_Init 'int '((int . 32))) + +(define window (pffi-call sdl2 + 'SDL_CreateWindow + 'pointer + (list (cons 'pointer (pffi-string->pointer "Testing pffi")) + (cons 'int 1) + (cons 'int 1) + (cons 'int 400) + (cons 'int 400) + (cons 'int 4)))) + +(define renderer (pffi-call sdl2 + 'SDL_CreateRenderer + 'pointer + (list (cons 'pointer window) + (cons 'int -1) + (cons 'int 2)))) + +(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer))) +(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer))) + +(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000)))) +