From 76eb8058a8c96c3f38c486430bae258ee2e2b783 Mon Sep 17 00:00:00 2001
From: retropikzel <retropikzel@iki.fi>
Date: Tue, 1 Apr 2025 20:34:19 +0300
Subject: [PATCH] Adding stklos support

---
 retropikzel/pffi.sld             |  4 +--
 retropikzel/pffi/gauche.scm      |  2 +-
 retropikzel/pffi/shared/main.scm |  6 ++--
 retropikzel/pffi/stklos.scm      | 54 ++++++++++++++++++++++----------
 4 files changed, 45 insertions(+), 21 deletions(-)

diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld
index b91734c..a9e2720 100644
--- a/retropikzel/pffi.sld
+++ b/retropikzel/pffi.sld
@@ -454,8 +454,8 @@
               pffi-pointer-free
               pffi-pointer-set!
               pffi-pointer-get
-              ;pffi-string->pointer
-              ;pffi-pointer->string
+              pffi-string->pointer
+              pffi-pointer->string
               pffi-struct-make
               pffi-struct-pointer
               pffi-struct-offset-get
diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm
index ff60457..687fa17 100644
--- a/retropikzel/pffi/gauche.scm
+++ b/retropikzel/pffi/gauche.scm
@@ -14,7 +14,7 @@
                        pffi-define))
 
 (select-module retropikzel.pffi.gauche)
-(dynamic-load "retropikzel/pffi/retropikzel-pffi-gauche")
+(dynamic-load "retropikzel/pffi/gauche-pffi")
 
 (define size-of-type
   (lambda (type)
diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm
index 553693f..411b6fe 100644
--- a/retropikzel/pffi/shared/main.scm
+++ b/retropikzel/pffi/shared/main.scm
@@ -222,5 +222,7 @@
                  (write searched-paths)
                  (newline)
                  (exit 1))
-               (pffi-shared-object-load shared-object
-                                        `((additional-versions ,additional-versions)))))))))))
+               (cond-expand
+                 (stklos shared-object)
+                 (else (pffi-shared-object-load shared-object
+                                        `((additional-versions ,additional-versions)))))))))))))
diff --git a/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm
index 54e23db..785a04d 100644
--- a/retropikzel/pffi/stklos.scm
+++ b/retropikzel/pffi/stklos.scm
@@ -83,20 +83,6 @@
       (free-bytes p)
       p)))
 
-#;(define pffi-string->pointer
-  (lambda (string-content)
-    string-content))
-
-#;(define pffi-pointer->string
-  (lambda (pointer)
-    (if (string? pointer)
-      pointer
-      (cpointer->string pointer))))
-
-(define pffi-shared-object-load
-  (lambda (header path options)
-    path))
-
 (define pffi-pointer-free
   (lambda (pointer)
     (free-bytes pointer)))
@@ -108,8 +94,44 @@
 
 (define pffi-pointer-set!
   (lambda (pointer type offset value)
-    (error "Not implemented")))
+    (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 'pointer) (pointer-set-c-pointer! pointer offset value)))))
 
 (define pffi-pointer-get
   (lambda (pointer type offset)
-    (error "Not implemented")))
+    (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 'pointer) (pointer-ref-c-pointer pointer offset)))))