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

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

@ -5,6 +5,7 @@
(scheme file)
(scheme process-context)
(chicken foreign)
(chicken locative)
(chicken syntax)
(chicken memory)
(chicken random))
@ -143,7 +144,7 @@
(define ,scheme-name (location external_123456789)))
))))
(define-syntax pffi-size-of
(define-syntax pffi-size-of-old
(er-macro-transformer
(lambda (expr rename compare)
(let ((type (car (cdr (car (cdr expr))))))
@ -165,9 +166,34 @@
((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(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)))))))
(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
(lambda (size)
(allocate size)))
@ -178,18 +204,22 @@
(define pffi-string->pointer
(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))
(define pffi-pointer->string
(lambda (pointer)
(if (string? pointer)
pointer
(cond ((string? pointer) pointer)
((pffi-pointer? pointer)
(let* ((size (strlen pointer))
(string-content (make-string size)))
(move-memory! pointer string-content size 0)
string-content))))
string-content))
(error "Argument not pointer or string" pointer))))
(define-syntax pffi-shared-object-load
(er-macro-transformer
@ -203,7 +233,8 @@
(define pffi-pointer-free
(lambda (pointer)
(free pointer)))
(when (pffi-pointer? pointer)
(free pointer))))
(define pffi-pointer-null?
(lambda (pointer)
@ -230,7 +261,7 @@
((equal? type 'unsigned-long) (pointer-u32-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 'pointer) (pointer-u32-set! (pointer+ pointer offset) value)))))
((equal? type 'pointer) (pointer-s32-set! (pointer+ pointer offset) value)))))
(define pffi-pointer-get
(lambda (pointer type offset)
@ -252,7 +283,8 @@
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
((equal? type 'float) (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
(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 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 '*) (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
(lambda (pointer type offset)
@ -147,7 +146,8 @@
((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 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
(lambda (pointer)

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

@ -63,7 +63,8 @@
(scheme file)
(scheme process-context)
(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-define
pffi-define-callback
@ -81,8 +82,13 @@
pffi-os-name)
(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
(cond-expand

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

@ -111,7 +111,9 @@
(define pffi-pointer-get
(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
(lambda (pointer)

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

@ -115,7 +115,8 @@
(define pffi-pointer-free
(lambda (pointer)
(c-free pointer)))
(when (pointer? pointer)
(c-free pointer))))
(define pffi-pointer-null?
(lambda (pointer)
@ -164,7 +165,9 @@
((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-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
(lambda (pointer)