Bug fixes

retropikzel/r7rs-pffi/version/main.rkt

@@ -84,6 +84,12 @@
           pffi-os-name)
   (begin
 
+    (define pffi-os-name
+      (cond-expand
+        (windows "windows")
+        (racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
+        (else "unix")))
+
     (define-syntax pffi-init
       (syntax-rules ()
         ((pffi-init)
@@ -91,12 +97,6 @@
            (chicken (import (chicken foreign)))
            (else #t)))))
 
-    (define pffi-os-name
-      (cond-expand
-        (windows "windows")
-        (racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
-        (else "unix")))
-
     (define library-version "v0-3-0")
     (define slash (cond-expand (windows (string #\\)) (else "/")))
 

retropikzel/r7rs-pffi/version/main.scm

@@ -83,6 +83,12 @@
           pffi-os-name)
   (begin
 
+    (define pffi-os-name
+      (cond-expand
+        (windows "windows")
+        (racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
+        (else "unix")))
+
     (define-syntax pffi-init
       (syntax-rules ()
         ((pffi-init)
@@ -90,12 +96,6 @@
            (chicken (import (chicken foreign)))
            (else #t)))))
 
-    (define pffi-os-name
-      (cond-expand
-        (windows "windows")
-        (racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
-        (else "unix")))
-
     (define library-version "v0-3-0")
     (define slash (cond-expand (windows (string #\\)) (else "/")))
 

retropikzel/r7rs-pffi/version/main.sld

@@ -83,6 +83,12 @@
           pffi-os-name)
   (begin
 
+    (define pffi-os-name
+      (cond-expand
+        (windows "windows")
+        (racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
+        (else "unix")))
+
     (define-syntax pffi-init
       (syntax-rules ()
         ((pffi-init)
@@ -90,12 +96,6 @@
            (chicken (import (chicken foreign)))
            (else #t)))))
 
-    (define pffi-os-name
-      (cond-expand
-        (windows "windows")
-        (racket (if (equal? (system-type 'os) 'windows) "windows" "unix"))
-        (else "unix")))
-
     (define library-version "v0-3-0")
     (define slash (cond-expand (windows (string #\\)) (else "/")))
 

retropikzel/r7rs-pffi/version/racket.scm

@@ -5,6 +5,7 @@
          (scheme file)
          (scheme process-context)
          (compatibility mlist)
+         (only (racket base) system-type)
          (ffi unsafe)
          (ffi vector))
  (export pffi-shared-object-load
@@ -44,7 +45,7 @@
          ((equal? type 'float) _float)
          ((equal? type 'double) _double)
          ((equal? type 'pointer) _pointer)
-         ((equal? type 'string) _pointer)
+         ((equal? type 'string) _string)
          ((equal? type 'void) _void)
          ((equal? type 'callback) _pointer)
          (else (error "pffi-type->native-type -- No such pffi type" type)))))
@@ -84,11 +85,29 @@
 
    (define pffi-string->pointer
      (lambda (string-content)
-       (cast string-content _string _pointer)))
+       (write string-content)
+       (newline)
+       (let* ((size (string-length string-content))
+              (pointer (pffi-pointer-allocate (+ size 1))))
+         (memmove pointer (cast string-content _string _pointer) size)
+         (display "STRING SIZE: ")
+         (display size)
+         (display " : ")
+         (write (cast pointer _pointer _string))
+         (newline)
+         pointer)))
 
    (define pffi-pointer->string
      (lambda (pointer)
-       (cast pointer _pointer _string)))
+     (let* ((size (string-length (cast pointer _pointer _string)))
+            (string-content (string-copy (cast pointer _pointer _string))))
+       (memmove (cast string-content _string _pointer) pointer size)
+       (display "SIZE: ")
+       (display size)
+       (display " : ")
+       (write string-content)
+       (newline)
+        string-content)))
 
    (define pffi-shared-object-load
      (lambda (header path)
@@ -104,19 +123,11 @@
 
    (define pffi-pointer-set!
      (lambda (pointer type offset value)
-       (cond
-         ((equal? type 'string)
-          (ptr-set! pointer (pffi-type->native-type type) 'abs offset (pffi-string->pointer value)))
-         (else
-           (ptr-set! pointer (pffi-type->native-type type) 'abs offset value)))))
+       (ptr-set! pointer (pffi-type->native-type type) 'abs offset value)))
 
    (define pffi-pointer-get
      (lambda (pointer type offset)
-       (cond
-         ((equal? type 'string)
-          (pffi-pointer->string (ptr-ref pointer (pffi-type->native-type type) 'abs offset)))
-         (else
-           (ptr-ref pointer (pffi-type->native-type type) 'abs offset)))))
+       (ptr-ref pointer (pffi-type->native-type type) 'abs offset)))
 
    (define pffi-pointer-deref
      (lambda (pointer)

retropikzel/r7rs-pffi/version/sagittarius.scm

@@ -50,8 +50,7 @@
 
     (define pffi-pointer?
       (lambda (object)
-        (or (string? object)
-            (pointer? object))))
+        (pointer? object)))
 
     (define-syntax pffi-define
       (syntax-rules ()
@@ -104,13 +103,13 @@
 
     (define pffi-string->pointer
       (lambda (string-content)
-        string-content))
+        (write string-content)
+        (newline)
+        (bytevector->pointer (string->utf8 string-content))))
 
     (define pffi-pointer->string
       (lambda (pointer)
-        (if (string? pointer)
-          pointer
-          (pointer->string pointer))))
+          (pointer->string pointer)))
 
     (define pffi-shared-object-load
       (lambda (header path)
@@ -127,51 +126,49 @@
 
     (define pffi-pointer-set!
       (lambda (pointer type offset value)
-        (let ((p pointer))
-          (cond ((equal? type 'int8) (pointer-set-c-int8_t! p offset value))
-                ((equal? type 'uint8) (pointer-set-c-uint8_t! p offset value))
-                ((equal? type 'int16) (pointer-set-c-int16_t! p offset value))
-                ((equal? type 'uint16) (pointer-set-c-uint16_t! p offset value))
-                ((equal? type 'int32) (pointer-set-c-int32_t! p offset value))
-                ((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
-                ((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
-                ((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
-                ((equal? type 'char) (pointer-set-c-char! p offset value))
-                ((equal? type 'short) (pointer-set-c-short! p offset value))
-                ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
-                ((equal? type 'int) (pointer-set-c-int! p offset value))
-                ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! p offset value))
-                ((equal? type 'long) (pointer-set-c-long! p offset value))
-                ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
-                ((equal? type 'float) (pointer-set-c-float! p offset value))
-                ((equal? type 'double) (pointer-set-c-double! p offset value))
-                ((equal? type 'void*) (pointer-set-c-pointer! p offset value))
-                ((equal? type 'pointer) (pointer-set-c-pointer! p offset value))))))
+        (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value))
+              ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value))
+              ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value))
+              ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value))
+              ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value))
+              ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value))
+              ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value))
+              ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value))
+              ((equal? type 'char) (pointer-set-c-char! pointer offset value))
+              ((equal? type 'short) (pointer-set-c-short! pointer offset value))
+              ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value))
+              ((equal? type 'int) (pointer-set-c-int! pointer offset value))
+              ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value))
+              ((equal? type 'long) (pointer-set-c-long! pointer offset value))
+              ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value))
+              ((equal? type 'float) (pointer-set-c-float! pointer offset value))
+              ((equal? type 'double) (pointer-set-c-double! pointer offset value))
+              ((equal? type 'void*) (pointer-set-c-pointer! pointer offset value))
+              ((equal? type 'string) (pointer-set-c-pointer! pointer offset value))
+              ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
 
     (define pffi-pointer-get
       (lambda (pointer type offset)
-        (let ((p pointer)
-              (native-type (pffi-type->native-type type)))
-          (cond ((equal? native-type 'int8_t) (pointer-ref-c-int8_t p offset))
-                ((equal? native-type 'uint8_t) (pointer-ref-c-uint8_t p offset))
-                ((equal? native-type 'int16_t) (pointer-ref-c-int16_t p offset))
-                ((equal? native-type 'uint16_t) (pointer-ref-c-uint16_t p offset))
-                ((equal? native-type 'int32_t) (pointer-ref-c-int32_t p offset))
-                ((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
-                ((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
-                ((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
-                ((equal? native-type 'char) (pointer-ref-c-char p offset))
-                ((equal? native-type 'short) (pointer-ref-c-short p offset))
-                ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))
-                ((equal? native-type 'int) (pointer-ref-c-int p offset))
-                ((equal? native-type 'unsigned-int) (pointer-ref-c-unsigned-int p offset))
-                ((equal? native-type 'long) (pointer-ref-c-long p offset))
-                ((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 'char*) (pffi-pointer->string (pointer-ref-c-pointer p offset)))
-                ))))
+        (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset))
+              ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset))
+              ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset))
+              ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset))
+              ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset))
+              ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset))
+              ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset))
+              ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset))
+              ((equal? type 'char) (pointer-ref-c-char pointer offset))
+              ((equal? type 'short) (pointer-ref-c-short pointer offset))
+              ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
+              ((equal? type 'int) (pointer-ref-c-int pointer offset))
+              ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
+              ((equal? type 'long) (pointer-ref-c-long pointer offset))
+              ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
+              ((equal? type 'float) (pointer-ref-c-float pointer offset))
+              ((equal? type 'double) (pointer-ref-c-double pointer offset))
+              ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
+              ((equal? type 'string) (pffi-pointer->string (pointer-ref-c-pointer pointer offset)))
+              ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
 
     (define pffi-pointer-deref
       (lambda (pointer)

test.scm

@@ -288,6 +288,7 @@
 (pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
 (assert = (atoi (pffi-string->pointer "100")) 100)
 
+(exit)
 ;; pffi-define-callback
 
 (print-header 'pffi-define-callback)
@@ -313,29 +314,25 @@
                       'void
                       (list 'pointer 'int 'int 'pointer)
                       (lambda (pointer size nmemb client-pointer)
-                        (set! result (string-append result (string-copy (pffi-pointer->string pointer))))))
+                        (set! result (string-append result (pffi-pointer->string pointer)))))
 
 (define handle (curl-easy-init))
 (define url "https://scheme.org")
 (debug url)
 (define curl-code1 (curl-easy-setopt-url handle CURLOPT-FOLLOWLOCATION url))
 (debug curl-code1)
-(when (not (= curl-code1 0)) (error (curl-easy-strerror curl-code1)))
 (assert = curl-code1 0)
 
 (define curl-code2 (curl-easy-setopt-url handle CURLOPT-URL url))
 (debug curl-code2)
-(when (not (= curl-code2 0)) (error (curl-easy-strerror curl-code2)))
 (assert = curl-code2 0)
 
 (define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
 (debug curl-code3)
-(when (not (= curl-code3 0)) (error (curl-easy-strerror curl-code3)))
 (assert = curl-code3 0)
 
 (define curl-code4 (curl-easy-perform handle))
 (debug curl-code4)
-(when (not (= curl-code4 0)) (error (curl-easy-strerror curl-code4)))
 (assert = curl-code4 0)
 
 (define http-code (pffi-pointer-allocate (pffi-size-of 'int)))