Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Small fixes

This commit is contained in:
retropikzel 2024-08-08 20:08:25 +03:00
parent 8e53578cb5
commit e0e7c15201
5 changed files with 63 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
retropikzel/r7rs-pffi/version/chicken.scm
View File

@ -5,6 +5,7 @@
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(chicken foreign) (chicken foreign)
(chicken locative)
(chicken syntax) (chicken syntax)
(chicken memory) (chicken memory)
(chicken random)) (chicken random))
@ -143,7 +144,7 @@
(define ,scheme-name (location external_123456789))) (define ,scheme-name (location external_123456789)))
)))) ))))
(define-syntax pffi-size-of (define-syntax pffi-size-of-old
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((type (car (cdr (car (cdr expr)))))) (let ((type (car (cdr (car (cdr expr))))))
@ -165,9 +166,34 @@
((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int)) ((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int))
((equal? type 'float) `(foreign-value "sizeof(float)" int)) ((equal? type 'float) `(foreign-value "sizeof(float)" int))
((equal? type 'double) `(foreign-value "sizeof(double)" int)) ((equal? type 'double) `(foreign-value "sizeof(double)" int))
((equal? type 'pointer) `(foreign-value "sizeof(int)" int)) ((equal? type 'pointer) `(foreign-value "sizeof(void*)" int))
((equal? type 'string) `(foreign-value "sizeof(void*)" int))
(else `(error "pffi-size-of -- No such pffi type" type))))))) (else `(error "pffi-size-of -- No such pffi type" type)))))))
(define pffi-size-of
(lambda (type)
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
((equal? type 'int16) (foreign-value "sizeof(int16_t)" int))
((equal? type 'uint16) (foreign-value "sizeof(uint16_t)" int))
((equal? type 'int32) (foreign-value "sizeof(int32_t)" int))
((equal? type 'uint32) (foreign-value "sizeof(uint32_t)" int))
((equal? type 'int64) (foreign-value "sizeof(int64_t)" int))
((equal? type 'uint64) (foreign-value "sizeof(uint64_t)" int))
((equal? type 'char) (foreign-value "sizeof(char)" int))
((equal? type 'unsigned-char) (foreign-value "sizeof(unsigned char)" int))
((equal? type 'short) (foreign-value "sizeof(short)" int))
((equal? type 'unsigned-short) (foreign-value "sizeof(unsigned short)" int))
((equal? type 'int) (foreign-value "sizeof(int)" int))
((equal? type 'unsigned-int) (foreign-value "sizeof(unsigned int)" int))
((equal? type 'long) (foreign-value "sizeof(long)" int))
((equal? type 'unsigned-long) (foreign-value "sizeof(unsigned long)" int))
((equal? type 'float) (foreign-value "sizeof(float)" int))
((equal? type 'double) (foreign-value "sizeof(double)" int))
((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
((equal? type 'string) (foreign-value "sizeof(void*)" int))
(else (error "pffi-size-of -- No such pffi type" type)))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)
(allocate size))) (allocate size)))
@ -178,18 +204,22 @@
(define pffi-string->pointer (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(location string-content))) (let* ((size (+ (string-length string-content) 1))
(pointer (pffi-pointer-allocate size)))
(move-memory! string-content pointer (- size 1) 0)
pointer)))
(pffi-define strlen #f 'strlen 'int (list 'pointer)) (pffi-define strlen #f 'strlen 'int (list 'pointer))
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(if (string? pointer) (cond ((string? pointer) pointer)
pointer ((pffi-pointer? pointer)
(let* ((size (strlen pointer)) (let* ((size (strlen pointer))
(string-content (make-string size))) (string-content (make-string size)))
(move-memory! pointer string-content size 0) (move-memory! pointer string-content size 0)
string-content)))) string-content))
(error "Argument not pointer or string" pointer))))
(define-syntax pffi-shared-object-load (define-syntax pffi-shared-object-load
(er-macro-transformer (er-macro-transformer
@ -203,7 +233,8 @@
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
(free pointer))) (when (pffi-pointer? pointer)
(free pointer))))
(define pffi-pointer-null? (define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)
@ -230,7 +261,7 @@
((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value)) ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value)) ((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value)) ((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
((equal? type 'pointer) (pointer-u32-set! (pointer+ pointer offset) value))))) ((equal? type 'pointer) (pointer-s32-set! (pointer+ pointer offset) value)))))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -252,7 +283,8 @@
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset))) ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset))) ((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset))) ((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset)))))) ((equal? type 'pointer) (pointer-s32-ref (pointer+ pointer offset)))
((equal? type 'string) (pffi-pointer->string (address->pointer (pffi-pointer-get pointer 'pointer offset)))))))
(define pffi-pointer-deref (define pffi-pointer-deref
(lambda (pointer) (lambda (pointer)

6
retropikzel/r7rs-pffi/version/guile.scm
View File

@ -124,8 +124,7 @@
((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness))) ((equal? native-type unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? native-type float) (bytevector-ieee-single-set! p offset value (native-endianness))) ((equal? native-type float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? native-type double) (bytevector-ieee-double-set! p offset value (native-endianness))) ((equal? native-type double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? native-type '*) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))) ((equal? native-type '*) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type)))))))
)))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -147,7 +146,8 @@
((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness))) ((equal? native-type unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? native-type float) (bytevector-ieee-single-ref p offset (native-endianness))) ((equal? native-type float) (bytevector-ieee-single-ref p offset (native-endianness)))
((equal? native-type double) (bytevector-ieee-double-ref p offset (native-endianness))) ((equal? native-type double) (bytevector-ieee-double-ref p offset (native-endianness)))
((equal? native-type '*) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))) ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))))))))
(define pffi-pointer-deref (define pffi-pointer-deref
(lambda (pointer) (lambda (pointer)

10
retropikzel/r7rs-pffi/version/main.scm
View File

@ -63,7 +63,8 @@
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(retropikzel r7rs-pffi version mit-scheme)))) (retropikzel r7rs-pffi version mit-scheme))))
(export pffi-shared-object-auto-load (export pffi-init
pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
pffi-define pffi-define
pffi-define-callback pffi-define-callback
@ -81,8 +82,13 @@
pffi-os-name) pffi-os-name)
(begin (begin
(define-syntax pffi-init
(syntax-rules ()
((pffi-init)
(cond-expand
(chicken (import (chicken foreign)))
(else #t)))))
#|doc Testing multiline comment |#
(define pffi-os-name (define pffi-os-name
(cond-expand (cond-expand

4
retropikzel/r7rs-pffi/version/racket.scm
View File

@ -111,7 +111,9 @@
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(ptr-ref pointer (pffi-type->native-type type) offset))) (if (equal? type 'string)
(pffi-pointer->string (ptr-ref pointer (pffi-type->native-type type) offset))
(ptr-ref pointer (pffi-type->native-type type) offset))))
(define pffi-pointer-deref (define pffi-pointer-deref
(lambda (pointer) (lambda (pointer)

7
retropikzel/r7rs-pffi/version/sagittarius.scm
View File

@ -115,7 +115,8 @@
(define pffi-pointer-free (define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
(c-free pointer))) (when (pointer? pointer)
(c-free pointer))))
(define pffi-pointer-null? (define pffi-pointer-null?
(lambda (pointer) (lambda (pointer)
@ -164,7 +165,9 @@
((equal? native-type 'unsigned-long) (pointer-ref-c-unsigned-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 'float) (pointer-ref-c-float p offset))
((equal? native-type 'double) (pointer-ref-c-double p offset)) ((equal? native-type 'double) (pointer-ref-c-double p offset))
((equal? native-type 'void*) (pointer-ref-c-pointer p offset)))))) ((equal? native-type 'void*) (pointer-ref-c-pointer p offset))
((equal? native-type 'char*) (pffi-pointer->string (pointer-ref-c-pointer p offset)))
))))
(define pffi-pointer-deref (define pffi-pointer-deref
(lambda (pointer) (lambda (pointer)