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

Backup

This commit is contained in:
retropikzel 2024-05-17 20:45:56 +03:00
parent 2a83156151
commit 1fc93b2f5a
8 changed files with 14 additions and 263 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

6
Makefile
View File

@ -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
cat retropikzel/pffi/${VERSION}/main.sld >> retropikzel/pffi/${VERSION}/main.rkt
#echo "#lang r7rs" > 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

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

@ -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"))

BIN
retropikzel/pffi/v0-1-0/compiled/main_rkt.zo
View File

Binary file not shown.

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

@ -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"))

BIN
retropikzel/pffi/v0-1-0/compiled/racket_rkt.zo
View File

Binary file not shown.

251
retropikzel/pffi/v0-1-0/main.rkt
View File

@ -1,250 +1,3 @@
#lang r7rs
;> # pffi
;> ## 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))))
(import (scheme base))
(include "main.sld")

16
retropikzel/pffi/v0-1-0/racket.rkt
View File

@ -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
;(pointer->bytevector pointer size)
))
(cast pointer _pointer _bytes)))
(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
))))