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

Progress on Gauche

This commit is contained in:
retropikzel 2025-04-27 17:45:41 +03:00
parent 1f9732020a
commit 3c75f1eb5a
5 changed files with 109 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
foreign/c.sld
View File

@ -289,6 +289,9 @@
;; c-variable ;; c-variable
;define-c-variable (?) ;define-c-variable (?)
) )
(cond-expand
(chicken-6 (include-relative "c/types.scm"))
(else (include "c/types.scm")))
(cond-expand (cond-expand
(chibi (include "c/primitives/chibi.scm")) (chibi (include "c/primitives/chibi.scm"))
(chicken-5 (export foreign-declare (chicken-5 (export foreign-declare

22
foreign/c/pointer.scm
View File

@ -16,13 +16,11 @@
(define-c-procedure c-malloc libc 'malloc 'pointer '(int)) (define-c-procedure c-malloc libc 'malloc 'pointer '(int))
(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) (define-c-procedure c-strlen libc 'strlen 'int '(pointer))
(cond-expand (define make-c-bytevector
;(chibi #t) ; FIXME (lambda (k . byte)
(else (define make-c-bytevector (if (null? byte)
(lambda (k . byte) (c-malloc k)
(if (null? byte) (bytevector->c-bytevector (make-bytevector k (car byte))))))
(c-malloc k)
(bytevector->c-bytevector (make-bytevector k (car byte))))))))
(define c-bytevector (define c-bytevector
(lambda bytes (lambda bytes
@ -111,16 +109,6 @@
(native-endianness) (native-endianness)
(c-size-of 'pointer))))) (c-size-of 'pointer)))))
#;(cond-expand
(kawa #t) ; Defined in kawa.scm
(chibi #t)
(else
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(c-memset-address (+ (c-memset-pointer->address c-bytevector 0 0) k)
byte
1)))))
(cond-expand (cond-expand
;(kawa #t) ; Defined in kawa.scm ;(kawa #t) ; Defined in kawa.scm
(else (define-syntax call-with-address-of-c-bytevector (else (define-syntax call-with-address-of-c-bytevector

6
foreign/c/primitives/chibi.scm
View File

@ -140,7 +140,7 @@
((equal? type 'pointer-address) 1) ((equal? type 'pointer-address) 1)
((equal? type 'callback) (get-ffi-type-pointer))))) ((equal? type 'callback) (get-ffi-type-pointer)))))
(define type->libffi-type #;(define type->libffi-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 1) (cond ((equal? type 'int8) 1)
((equal? type 'uint8) 2) ((equal? type 'uint8) 2)
@ -181,8 +181,8 @@
(lambda arguments (lambda arguments
(let* ((return-pointer (let* ((return-pointer
(internal-ffi-call (length argument-types) (internal-ffi-call (length argument-types)
(type->libffi-type return-type) (type->libffi-type-number return-type)
(map type->libffi-type argument-types) (map type->libffi-type-number argument-types)
c-function c-function
(c-size-of return-type) (c-size-of return-type)
arguments))) arguments)))

96
foreign/c/primitives/gauche.scm
View File

@ -5,18 +5,45 @@
c-bytevector-u8-ref c-bytevector-u8-ref
;pointer-null ;pointer-null
;pointer-null? ;pointer-null?
make-c-bytevector ;make-c-bytevector
;pointer-address ;pointer-address
c-bytevector? c-bytevector?
c-free c-free
pointer-set! ;pointer-set!
pointer-get ;pointer-get
define-c-procedure define-c-procedure
define-c-callback)) define-c-callback))
(select-module foreign.c.primitives.gauche) (select-module foreign.c.primitives.gauche)
(dynamic-load "foreign/c/lib/gauche") (dynamic-load "foreign/c/lib/gauche")
;; FIXME This is copied from types.scm
(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 size-of-type (define size-of-type
(lambda (type) (lambda (type)
(cond (cond
@ -46,7 +73,7 @@
(lambda (path options) (lambda (path options)
(shared-object-load path))) (shared-object-load path)))
(define make-c-bytevector #;(define make-c-bytevector
(lambda (size) (lambda (size)
(pointer-allocate size))) (pointer-allocate size)))
@ -54,7 +81,7 @@
(lambda (pointer) (lambda (pointer)
(pointer? pointer))) (pointer? pointer)))
(define c-free #;(define c-free
(lambda (pointer) (lambda (pointer)
(pointer-free pointer))) (pointer-free pointer)))
@ -105,7 +132,7 @@
((equal? type 'void) (pointer-get-pointer pointer offset)) ((equal? type 'void) (pointer-get-pointer pointer offset))
((equal? type 'pointer) (pointer-get-pointer pointer offset))))) ((equal? type 'pointer) (pointer-get-pointer pointer offset)))))
(define type->libffi-type #;(define type->libffi-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) (get-ffi-type-int8)) (cond ((equal? type 'int8) (get-ffi-type-int8))
((equal? type 'uint8) (get-ffi-type-uint8)) ((equal? type 'uint8) (get-ffi-type-uint8))
@ -130,7 +157,32 @@
((equal? type 'pointer) (get-ffi-type-pointer)) ((equal? type 'pointer) (get-ffi-type-pointer))
((equal? type 'callback) (get-ffi-type-pointer))))) ((equal? type 'callback) (get-ffi-type-pointer)))))
(define argument->pointer #;(define type->libffi-type
(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 'bool) 11)
((equal? type 'short) 12)
((equal? type 'unsigned-short) 13)
((equal? type 'int) 14)
((equal? type 'unsigned-int) 15)
((equal? type 'long) 16)
((equal? type 'unsigned-long) 17)
((equal? type 'float) 18)
((equal? type 'double) 19)
((equal? type 'void) 20)
((equal? type 'pointer) 21)
((equal? type 'callback) 21))))
#;(define argument->pointer
(lambda (value type) (lambda (value type)
(cond ((procedure? value) (scheme-procedure-to-pointer value)) (cond ((procedure? value) (scheme-procedure-to-pointer value))
(else (let ((pointer (make-c-bytevector (size-of-type type)))) (else (let ((pointer (make-c-bytevector (size-of-type type))))
@ -142,23 +194,21 @@
(dlerror) ;; Clean all previous errors (dlerror) ;; Clean all previous errors
(let ((c-function (dlsym shared-object c-name)) (let ((c-function (dlsym shared-object c-name))
(maybe-dlerror (dlerror))) (maybe-dlerror (dlerror)))
#;(when (not (pointer-null? maybe-dlerror))
(error (c-bytevector->string maybe-dlerror)))
(lambda arguments (lambda arguments
(let ((return-value (make-c-bytevector (let ((return-pointer (internal-ffi-call (length argument-types)
(if (equal? return-type 'void) (type->libffi-type-number return-type)
0 (map type->libffi-type-number argument-types)
(size-of-type return-type))))) c-function
(internal-ffi-call (length argument-types) (size-of-type return-type)
(type->libffi-type return-type) arguments)))
(map type->libffi-type argument-types) (display "HERE: ")
c-function (write return-pointer)
return-value (newline)
(map argument->pointer (display "HERE2: ")
arguments (write (pointer-get return-pointer return-type 0))
argument-types)) (newline)
(cond ((not (equal? return-type 'void)) (when (not (equal? return-type 'void))
(pointer-get return-value return-type 0)))))))) (pointer-get return-pointer return-type 0)))))))
(define-syntax define-c-procedure (define-syntax define-c-procedure
(syntax-rules () (syntax-rules ()

25
foreign/c/types.scm Normal file
View File

@ -0,0 +1,25 @@
(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)))))