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

Merge remote-tracking branch 'origin/master' into callback-racket

This commit is contained in:
retropikzel 2024-07-01 20:14:57 +03:00
parent 7c15de41e8 c37e72bf8d
commit b02222ad35
2 changed files with 62 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
retropikzel/pffi/v0-2-2/chicken.scm
View File

@ -6,9 +6,11 @@
(scheme process-context)
(chicken foreign)
(chicken syntax)
(chicken memory))
(chicken memory)
(chicken random))
(export pffi-shared-object-load
pffi-define
pffi-define-callback
pffi-size-of
pffi-pointer-allocate
pffi-pointer-null
@ -45,6 +47,7 @@
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
((equal? type 'callback) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))) )
(define pffi-pointer?
@ -77,6 +80,7 @@
((equal? type 'pointer) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
((equal? type 'callback) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
@ -88,9 +92,56 @@
(map pffi-type->native-type (map car (map cdr types)))))))
(if (null? argument-types)
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name))
(foreign-safe-lambda ,return-type ,c-name))
`(define ,scheme-name
(foreign-lambda ,return-type ,c-name ,@ argument-types)))))))
(foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
(define-syntax pffi-define-callback
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type
(lambda (type)
(cond ((equal? type 'int8) 'byte)
((equal? type 'uint8) 'unsigned-byte)
((equal? type 'int16) 'int16_t)
((equal? type 'uint16) 'uint16_t)
((equal? type 'int32) 'int32)
((equal? type 'uint32) 'unsigned-int32)
((equal? type 'int64) 'integer-64)
((equal? type 'uint64) 'unsigned-integer64)
((equal? type 'char) 'char)
((equal? type 'unsigned-char) 'unsigned-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) 'c-pointer)
((equal? type 'string) 'c-string)
((equal? type 'void) 'void)
((equal? type 'callback) 'c-pointer)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
(scheme-name (car (cdr expr)))
(return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr)))))))
(argument-types
(let ((types (cdr (car (cdr (cdr (cdr expr)))))))
(if (null? types)
'()
(map pffi-type->native-type (map car (map cdr types))))))
(argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))
(arguments (map
(lambda (name type)
`(,name ,type))
argument-types argument-names))
(procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
`(begin (define-external ,(cons 'external_123456789 arguments)
,return-type
(begin ,@ procedure-body))
(define ,scheme-name (location external_123456789)))
))))
(define-syntax pffi-size-of
(er-macro-transformer
@ -127,10 +178,7 @@
(define pffi-string->pointer
(lambda (string-content)
(let* ((size (string-length string-content))
(pointer (pffi-pointer-allocate size)))
(move-memory! string-content pointer size 0)
pointer)))
(location string-content)))
(pffi-define strlen #f 'strlen 'int (list 'pointer))

9
test/800_libcurl.scm
View File

@ -39,13 +39,18 @@
(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url))
(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url))
(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
(display "Curl code 1: ")
(display curl-code1)
(newline)
(display "Curl code 2: ")
(display curl-code2)
(newline)
(display "Curl code 3: ")
(display curl-code3)
(newline)
(curl-easy-perform handle)
(display "Perform: ")
(write (curl-easy-perform handle))
(newline)
(display "Response length: ")
(display (string-length result))
(newline)