Backup

.gitignore

@@ -7,6 +7,8 @@ docuptmp
 *.o*
 *.meta
 *.link
+*.dep
+*.zo
 old
 retropikzel.*
 import

Makefile

@@ -14,11 +14,11 @@ CHICKEN_I=csi -R r7rs
 GERBIL=gxc -prelude :scheme/r7rs -exe
 GERBIL_I=gxi --lang r7rs
 
-build: build-rkt build-main-scm build-main-chicken build-main-gambit build-main-gerbil
+build: build-main-scm build-main-chicken build-main-gambit build-main-gerbil
 
 build-rkt:
-	echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt
+	#echo "#lang r7rs" > retropikzel/pffi/${VERSION}/main.rkt
-	cat retropikzel/pffi/${VERSION}/main.sld >> retropikzel/pffi/${VERSION}/main.rkt
+	#cat retropikzel/pffi/${VERSION}/main.sld >> retropikzel/pffi/${VERSION}/main.rkt
 
 build-main-scm:
 	cp retropikzel/pffi/${VERSION}/main.sld retropikzel/pffi/${VERSION}/main.scm

retropikzel/pffi/v0-1-0/compiled/main_rkt.dep

@@ -1 +0,0 @@
-("8.12" ta6le ("ef25d0339315600c996485e29d2d36b0be50ef74" . "87ea6db5c29da02402ccf3308ea25984d84f8e9f") (collects #"r7rs" #"base.rkt") (collects #"r7rs" #"file.rkt") (collects #"r7rs" #"lang" #"reader.rkt") (collects #"r7rs" #"main.rkt") (collects #"r7rs" #"process-context.rkt") (collects #"r7rs" #"write.rkt") (collects #"racket" #"base.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"retropikzel" #"pffi" #"v0-1-0" #"racket.rkt"))

retropikzel/pffi/v0-1-0/compiled/racket_rkt.dep

@@ -1 +0,0 @@
-("8.12" ta6le ("213d7907ee3cf2051004e3be2f9a67102c0176ce" . "c6039c9fe52ff5953361b25f7570ae33857df055") (collects #"compatibility" #"mlist.rkt") (collects #"ffi" #"unsafe.rkt") (collects #"r7rs" #"base.rkt") (collects #"r7rs" #"file.rkt") (collects #"r7rs" #"lang" #"reader.rkt") (collects #"r7rs" #"main.rkt") (collects #"r7rs" #"process-context.rkt") (collects #"r7rs" #"write.rkt") (collects #"racket" #"base.rkt") (collects #"racket" #"runtime-config.rkt"))

retropikzel/pffi/v0-1-0/main.rkt

@@ -1,250 +1,3 @@
 #lang r7rs
-;> # pffi
+(import (scheme base))
-
+(include "main.sld")
-;> ## Procedures
-(define-library
-  (retropikzel pffi v0-1-0 main)
-  (cond-expand
-    (sagittarius
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 sagittarius)))
-    (guile
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 guile)))
-    (racket
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (only (racket base) system-type)
-              (retropikzel pffi v0-1-0 racket)))
-    (stklos
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (stklos)
-              (retropikzel pffi v0-1-0 stklos)))
-    (kawa
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)))
-    (cyclone
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 cyclone)))
-    (gambit
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 gambit)))
-    (chicken
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 chicken)))
-    (chibi
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 chibi)))
-    (mit-scheme
-      (import (scheme base)
-              (scheme write)
-              (scheme file)
-              (scheme process-context)
-              (retropikzel pffi v0-1-0 mit-scheme))))
-  (export pffi-shared-object-auto-load
-          pffi-shared-object-load
-          pffi-define
-          pffi-size-of
-          pffi-pointer-allocate
-          pffi-pointer-null
-          pffi-string->pointer
-          pffi-pointer->string
-          pffi-pointer->bytevector
-          pffi-pointer-free
-          pffi-pointer?
-          pffi-pointer-null?
-          pffi-pointer-set!
-          pffi-pointer-get
-          pffi-pointer-deref)
-  (begin
-
-
-
-    (define library-version "v0-1-0")
-
-    ;> ## Procedures
-
-    (define platform-file-extension
-      (cond-expand
-        (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
-        (windows ".dll")
-        (else ".so")))
-
-    (define platform-version-file-extension
-      (cond-expand
-        (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
-        (windows ".dll")
-        (else ".so.0")))
-
-    (define platform-lib-prefix
-      (cond-expand
-        (racket (if (equal? (system-type 'os) 'windows) "" "lib"))
-        (windows "")
-        (else "lib")))
-
-    (define pffi-types
-      '(int8
-         uint8
-         int16
-         uint16
-         int32
-         uint32
-         int64
-         uint64
-         intptr
-         uintptr
-         char
-         unsigned-char
-         short
-         unsigned-short
-         int
-         unsigned-int
-         long
-         unsigned-long
-         float
-         double
-         pointer))
-
-    (define string-split
-      (lambda (str mark)
-        (let* ((str-l (string->list str))
-               (res (list))
-               (last-index 0)
-               (index 0)
-               (splitter (lambda (c)
-                           (cond ((char=? c mark)
-                                  (begin
-                                    (set! res (append res (list (string-copy str last-index index))))
-                                    (set! last-index (+ index 1))))
-                                 ((equal? (length str-l) (+ index 1))
-                                  (set! res (append res (list (string-copy str last-index (+ index 1)))))))
-                           (set! index (+ index 1)))))
-          (for-each splitter str-l)
-          res)))
-
-    (define auto-load-paths
-      (append
-        (cond-expand
-          (windows
-            (append
-              (if (get-environment-variable "SYSTEM")
-                (list (get-environment-variable "SYSTEM"))
-                (list))
-              (if (get-environment-variable "WINDIR")
-                (list (get-environment-variable "WINDIR"))
-                (list))
-              (list ".")
-              (string-split (get-environment-variable "PATH") #\;)))
-          (else
-            (append
-              ; Guix
-              (list (if (get-environment-variable "GUIX_ENVIRONMENT")
-                      (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
-                      "")
-                    "/run/current-system/profile/lib")
-              ; Debian
-              (if (get-environment-variable "LD_LIBRARY_PATH")
-                (list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:))
-                (list))
-              (list "/lib/x86_64-linux-gnu"
-                    "/usr/lib/x86_64-linux-gnu"
-                    "/usr/local/lib"))))))
-
-    ;> ### pffi-shared-object-load
-    ;>
-    ;> Arguments:
-    ;> - path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
-    ;>
-    ;> Returns:
-    ;>
-
-
-
-
-    ;> ### pffi-shared-object-auto-load
-    ;>
-    ;> Arguments:
-    ;> - object-name (symbol)
-    ;>  - The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
-    ;> - addition-paths (list (string)...)
-    ;>  - Any additional paths you want to search for the library
-    ;>
-    ;> Returns:
-    ;> - (object) Shared object, the type depends on the implementation
-
-    (define-syntax pffi-shared-object-auto-load
-      (syntax-rules ()
-        ((pffi-shared-object-auto-load headers object-name additional-paths)
-         (cond-expand
-           (cyclone (pffi-shared-object-load headers object-path))
-           (chicken (pffi-shared-object-load headers object-path))
-           (else
-             (let* ((paths (append auto-load-paths additional-paths))
-                    (shared-object #f))
-               (for-each
-                 (lambda (path)
-                   (if (not shared-object)
-                     (let ((object-path
-                             (string-append path
-                                            "/"
-                                            object-name
-                                            platform-file-extension))
-                           (object-version-path
-                             (string-append path
-                                            "/"
-                                            object-name
-                                            platform-version-file-extension))
-                           (object-lib-path
-                             (string-append path
-                                            "/"
-                                            platform-lib-prefix
-                                            object-name
-                                            platform-file-extension))
-                           (object-version-lib-path
-                             (string-append path
-                                            "/"
-                                            platform-lib-prefix
-                                            object-name
-                                            platform-version-file-extension)))
-                       (cond
-                         ((file-exists? object-path)
-                          (set! shared-object (pffi-shared-object-load headers object-path)))
-                         ((file-exists? object-version-path)
-                          (set! shared-object (pffi-shared-object-load headers object-version-path)))
-                         ((file-exists? object-lib-path)
-                          (set! shared-object (pffi-shared-object-load headers object-lib-path)))
-                         ((file-exists? object-version-lib-path)
-                          (set! shared-object (pffi-shared-object-load headers object-version-lib-path)))))))
-                 paths)
-               (if (not shared-object)
-                 (error "Could not load shared object" object-name)
-                 shared-object)))))))
-
-    (cond-expand
-      (kawa (include "kawa.scm"))
-      (else #t))))

retropikzel/pffi/v0-1-0/racket.rkt

@@ -7,7 +7,8 @@
           (scheme file)
           (scheme process-context)
           (compatibility mlist)
-          (ffi unsafe))
+          (ffi unsafe)
+          (ffi vector))
   (export pffi-shared-object-load
           pffi-define
           pffi-size-of
@@ -34,7 +35,6 @@
               ((equal? type 'uint32) _uint32)
               ((equal? type 'int64) _int64)
               ((equal? type 'uint64) _uint64)
-              ;((equal? type 'char) _int32)
               ((equal? type 'char) _int)
               ((equal? type 'unsigned-char) _int)
               ((equal? type 'short) _short)
@@ -86,10 +86,7 @@
 
     (define pffi-pointer->bytevector
       (lambda (pointer size)
-        #f
+        (cast pointer _pointer _bytes)))
-        ;(pointer->bytevector pointer size)
-
-        ))
 
     (define pffi-shared-object-load
       (lambda (header path)
@@ -106,13 +103,14 @@
 
     (define pffi-pointer-set!
       (lambda (pointer type offset value)
-        (ptr-set! pointer type offset 'abs value)))
+        (ptr-set! pointer (pffi-type->native-type type) offset value)))
 
     (define pffi-pointer-get
       (lambda (pointer type offset)
-        (ptr-ref pointer type 'abs offset)))
+        (ptr-ref pointer (pffi-type->native-type type) offset)))
 
     (define pffi-pointer-deref
       (lambda (pointer)
-        #f ; TODO FIX
+        pointer
+        ;#f ; TODO FIX
         ))))