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

General cleanup of code

This commit is contained in:
retropikzel 2025-05-02 06:35:46 +03:00
parent 30827c3f9a
commit b87f3d98d9
5 changed files with 41 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
foreign/c.sld
View File

@ -207,7 +207,7 @@
(ypsilon c-ffi)
(ypsilon c-types)
(only (core) define-macro syntax-case))))
(export ;; Primitives
(export ;;;; Primitives
c-size-of
define-c-library
define-c-procedure
@ -218,11 +218,12 @@
c-bytevector-pointer-set!
c-bytevector-pointer-ref
;; c-bytevector
;;;; c-bytevector
make-c-bytevector
make-c-null
c-null?
c-free
native-endianness
;; TODO Docs for all of these
;c-bytevector->address
;address->c-bytevector
c-bytevector-s8-set!
c-bytevector-s8-ref
c-bytevector-s16-set!
@ -261,23 +262,14 @@
c-bytevector-ieee-double-native-set!
c-bytevector-ieee-double-ref
c-bytevector-ieee-double-native-ref
;; c-bytevector
make-c-bytevector
;c-bytevector ;; TODO docs, tests
make-c-null
c-null?
c-free
c-string-length ;; TODO Documentation, Testing
bytevector->c-bytevector
c-bytevector->bytevector
call-with-address-of-c-bytevector ;; Todo Documentation
call-with-address-of
string->c-utf8
c-utf8->string
;c-bytevector-u8-ref ;; TODO Documentation, Testing
;c-string-length ;; TODO Documentation, Testing
;; c-struct
;pffi-define-struct;define-c-struct
@ -301,10 +293,8 @@
;define-c-variable (?)
)
(cond-expand
(chicken-6 (include-relative "c/types.scm")
(include-relative "c/c-bytevector-get.scm"))
(else (include "c/types.scm")
(include "c/c-bytevector-get.scm")))
(chicken-6 (include-relative "c/internal.scm"))
(else (include "c/internal.scm")))
(cond-expand
(chibi (include "c/primitives/chibi.scm"))
(chicken-5 (export foreign-declare

26
foreign/c/c-bytevector-get.scm → foreign/c/internal.scm
View File

@ -1,3 +1,29 @@
(define type->libffi-type-number
(lambda (type)
(cond ((equal? type 'int8) 1)
((equal? type 'uint8) 2)
((equal? type 'int16) 3)
((equal? type 'uint16) 4)
((equal? type 'int32) 5)
((equal? type 'uint32) 6)
((equal? type 'int64) 7)
((equal? type 'uint64) 8)
((equal? type 'char) 9)
((equal? type 'unsigned-char) 10)
((equal? type 'short) 11)
((equal? type 'unsigned-short) 12)
((equal? type 'int) 13)
((equal? type 'unsigned-int) 14)
((equal? type 'long) 15)
((equal? type 'unsigned-long) 16)
((equal? type 'float) 17)
((equal? type 'double) 18)
((equal? type 'void) 19)
((equal? type 'pointer) 20)
((equal? type 'pointer-address) 21)
((equal? type 'callback) 22)
(else (error "Undefined type" type)))))
(define c-bytevector-get
(lambda (pointer type offset)
(cond ((equal? type 'int8) (c-bytevector-s8-ref pointer offset))

2
foreign/c/pointer.scm
View File

@ -111,7 +111,7 @@
(cond-expand
;(kawa #t) ; Defined in kawa.scm
(else (define-syntax call-with-address-of-c-bytevector
(else (define-syntax call-with-address-of
(syntax-rules ()
((_ input-pointer thunk)
(let ((address-pointer (make-c-bytevector (c-size-of 'pointer))))

25
foreign/c/types.scm
View File

@ -1,25 +0,0 @@
(define type->libffi-type-number
(lambda (type)
(cond ((equal? type 'int8) 1)
((equal? type 'uint8) 2)
((equal? type 'int16) 3)
((equal? type 'uint16) 4)
((equal? type 'int32) 5)
((equal? type 'uint32) 6)
((equal? type 'int64) 7)
((equal? type 'uint64) 8)
((equal? type 'char) 9)
((equal? type 'unsigned-char) 10)
((equal? type 'short) 11)
((equal? type 'unsigned-short) 12)
((equal? type 'int) 13)
((equal? type 'unsigned-int) 14)
((equal? type 'long) 15)
((equal? type 'unsigned-long) 16)
((equal? type 'float) 17)
((equal? type 'double) 18)
((equal? type 'void) 19)
((equal? type 'pointer) 20)
((equal? type 'pointer-address) 21)
((equal? type 'callback) 22)
(else (error "Undefined type" type)))))

6
tests/addressof.scm
View File

@ -71,7 +71,7 @@
(write value)
(newline)))))
;; call-with-address-of-c-bytevector
;; call-with-address-of
(define-c-library c-testlib
'("libtest.h")
@ -79,7 +79,7 @@
'((additional-paths ("." "./tests"))))
(print-header 'call-with-address-of-c-bytevector)
(print-header 'call-with-address-of)
(define-c-procedure test-passing-pointer-address
c-testlib
@ -92,7 +92,7 @@
(assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 100) #t)
(debug (c-bytevector-s32-native-ref input-pointer 0))
(debug input-pointer)
(call-with-address-of-c-bytevector
(call-with-address-of
input-pointer
(lambda (address)
(test-passing-pointer-address input-pointer address)))