diff --git a/retropikzel/pffi/v0-2-2/chicken.scm b/retropikzel/pffi/v0-2-2/chicken.scm index abbaacb..045d92e 100644 --- a/retropikzel/pffi/v0-2-2/chicken.scm +++ b/retropikzel/pffi/v0-2-2/chicken.scm @@ -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)) diff --git a/test/800_libcurl.scm b/test/800_libcurl.scm index d07ad12..a46c9be 100644 --- a/test/800_libcurl.scm +++ b/test/800_libcurl.scm @@ -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)