From 2f8166a779d861f1db8e5b73f9e97c5d424e9c6c Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 28 Mar 2026 17:02:31 +0200 Subject: [PATCH] Backup --- Makefile | 29 ++++- retropikzel/gi-repository.scm | 172 ++++++++++++++++++++++++++++- retropikzel/gi-repository.sld | 11 +- retropikzel/gi-repository/test.scm | 112 +++++++++++-------- 4 files changed, 264 insertions(+), 60 deletions(-) diff --git a/Makefile b/Makefile index fa24eb4..af1ff23 100644 --- a/Makefile +++ b/Makefile @@ -24,6 +24,13 @@ SFX=sps LIB_PATHS=-I .akku/lib endif +APT_PACKAGES= +CSC_OPTIONS= +ifeq "${LIBRARY}" "gi-repository" +APT_PACKAGES=libgirepository-2.0-dev +CSC_OPTIONS=-L -lgirepository-2.0 -L -lgobject-2.0 -L -lglib-2.0 +endif + all: build build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION @@ -42,20 +49,34 @@ install: testfiles: build rm -rf .tmp mkdir -p .tmp + cp -r retropikzel .tmp/ cp ${PKG} .tmp/ # R6RS testfiles - printf "#!r6rs\n(import (except (rnrs) remove) (srfi :64) (retropikzel ${LIBRARY}))" > .tmp/test.sps + printf "#!r6rs\n(import (except (rnrs) remove) (srfi :64) (foreign c) (retropikzel ${LIBRARY}))" > .tmp/test.sps cat ${TESTFILE} >> .tmp/test.sps # R7RS testfiles - echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (retropikzel ${LIBRARY}))" > .tmp/test.scm + echo "(import (scheme base) (scheme write) (scheme read) (scheme char) (scheme file) (scheme process-context) (srfi 64) (foreign c) (retropikzel ${LIBRARY}))" > .tmp/test.scm cat ${TESTFILE} >> .tmp/test.scm test: testfiles - cd .tmp && COMPILE_R7RS=${SCHEME} compile-r7rs -o test-program test.${SFX} + cd .tmp && \ + COMPILE_R7RS=${SCHEME} \ + CSC_OPTIONS="${CSC_OPTIONS}" \ + compile-r7rs \ + -o test-program \ + test.${SFX} cd .tmp && ./test-program test-docker: testfiles - cd .tmp && SNOW_PACKAGES="srfi.64 foreign.c" COMPILE_R7RS=${SCHEME} test-r7rs -o test-program test.${SFX} ${PKG} + cd .tmp && \ + COMPILE_R7RS=${SCHEME} \ + CSC_OPTIONS="${CSC_OPTIONS}" \ + SNOW_PACKAGES="srfi.64 foreign.c" \ + APT_PACKAGES="${APT_PACKAGES}" \ + test-r7rs \ + -o test-program \ + test.${SFX} \ + ${PKG} clean: git clean -X -f diff --git a/retropikzel/gi-repository.scm b/retropikzel/gi-repository.scm index f78ea04..17e4258 100644 --- a/retropikzel/gi-repository.scm +++ b/retropikzel/gi-repository.scm @@ -1,10 +1,174 @@ (define-c-library libc '("stdlib.h") #f '()) +(define-c-procedure c-perror libc 'perror 'void '(pointer)) + (define-c-library c-gi '("girepository/girepository.h") "girepository-2.0" '((additional-versions ("0")))) -(define-c-procedure gi-repository-new c-gi 'gi_repository_new 'pointer '()) -(define-c-procedure gi-repository-require c-gi 'gi_repository_require 'pointer '(pointer pointer pointer int pointer)) -(define-c-procedure gi-repository-find-by-name c-gi 'gi_repository_find_by_name 'pointer '(pointer pointer pointer)) -(define-c-procedure gi-function-info-invoke c-gi 'gi_function_info_invoke 'int '(pointer pointer int pointer int pointer pointer)) + +(define-c-procedure c-gi-repository-new c-gi 'gi_repository_new 'pointer '()) +(define-c-procedure c-gi-repository-require c-gi 'gi_repository_require 'pointer '(pointer pointer pointer int pointer)) +(define-c-procedure c-gi-repository-find-by-name c-gi 'gi_repository_find_by_name 'pointer '(pointer pointer pointer)) + +(define-c-procedure c-gi-base-info-get-name c-gi 'gi_base_info_get_name 'pointer '(pointer)) +(define-c-procedure c-gi-base-info-get-namespace c-gi 'gi_base_info_get_namespace 'pointer '(pointer)) +(define-c-procedure c-gi-base-info-get-typelib c-gi 'gi_base_info_get_typelib 'pointer '(pointer)) +(define-c-procedure c-gi-base-info-get-attribute c-gi 'gi_base_info_get_attribute 'pointer '(pointer pointer)) +(define-c-procedure c-gi-base-info-get-namespace c-gi 'gi_base_info_get_namespace 'pointer '(pointer)) + +(define-c-procedure c-gi-function-info-invoke c-gi 'gi_function_info_invoke 'int '(pointer pointer int pointer int pointer pointer)) + +(define-c-procedure c-gi-callable-info-get-return-type c-gi 'gi_callable_info_get_return_type 'pointer '(pointer)) +(define-c-procedure c-gi-callable-info-get-n-args c-gi 'gi_callable_info_get_n_args 'uint '(pointer)) +(define-c-procedure c-gi-callable-info-get-arg c-gi 'gi_callable_info_get_arg 'pointer '(pointer uint)) + +(define-c-procedure c-gi-arg-info-get-type-info c-gi 'gi_arg_info_get_type_info 'pointer '(pointer)) + +(define-c-procedure c-gi-type-info-get-tag c-gi 'gi_type_info_get_tag 'uint '(pointer)) +(define-c-procedure c-gi-type-info-get-interface c-gi 'gi_type_info_get_interface 'pointer '(pointer)) + + + +(define-c-procedure c-gi-object-info-find-method c-gi 'gi_object_info_find_method 'pointer '(pointer pointer)) + +(define-c-struct-type gerror '((domain u32) (code int) (message pointer))) + +(define GI-TYPE-TAG-UTF8 13) +(define GI-TYPE-TAG-INTERFACE 16) + +(define (gi-repository name version) + (let ((repository (c-gi-repository-new)) + (err (c-bytevector-null))) + (call-with-address-of + err + (lambda (err-address) + (c-gi-repository-require repository + (string->c-bytevector name) + (string->c-bytevector version) + 0 + err-address))) + (when (not (c-bytevector-null? err)) + (let* ((error-list (c-bytevector->list pointer gerror)) + (msg (c-bytevector->string (cdr (assoc 'message error-list))))) + (c-bytevector-free (cdr (assoc 'message error-list))) + (c-bytevector-free repository) + ;(c-bytevector-free err) + (error (string-append "load-gi-repository: " msg) + (car error-list) + (cadr error-list)))) + repository)) + +(define (gi-object repository namespace name) + (let ((base-info + (c-gi-repository-find-by-name repository + (string->c-bytevector namespace) + (string->c-bytevector name)))) + (when (c-bytevector-null? base-info) + (c-perror (string->c-bytevector "(C perror) gi-object")) + (error "gi-object: ERROR" namespace name base-info)) + base-info)) + +(define (gi-info-namespace info) + (c-bytevector->string (c-gi-base-info-get-namespace info))) +(define gi-object-namespace gi-info-namespace) + +(define (gi-info-name info) + (c-bytevector->string (c-gi-base-info-get-name info))) +(define gi-object-name gi-info-name) + +(define (gi-type->foreign-c-type type-info) + (let ((tag (c-gi-type-info-get-tag type-info))) + (cond + ((= tag GI-TYPE-TAG-UTF8) 'pointer) + ((= tag GI-TYPE-TAG-INTERFACE) + (display "HERE: ") + (write (c-bytevector->string (c-gi-base-info-get-namespace (c-gi-type-info-get-interface type-info)))) + (newline) + (write (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info)))) + (newline) + 'int) ;; FIXME + ))) + + +(define (gi-object-invoke object method-name . args) + (letrec* + ((method-info (c-gi-object-info-find-method object method-name)) + (method-return-info (c-gi-callable-info-get-return-type method-info)) + (return-type (gi-type->foreign-c-type method-return-info)) + (n-args (let ((n-args (c-gi-callable-info-get-n-args method-info))) + (when (not (= n-args (length args))) + (error + (string-append "gi-object-invoke: Argument count mismatch, got " + (number->string (length args)) + ", wanted " + (number->string n-args)) + (gi-object-namespace object) + (gi-object-name object) + method-name)) + n-args)) + (arg-info-looper + (lambda (index result) + (if (= index n-args) + result + (arg-info-looper + (+ index 1) + (append + result + (list + (let* ((arg-info (c-gi-callable-info-get-arg method-info index)) + (type-info (c-gi-arg-info-get-type-info arg-info)) + (type (gi-type->foreign-c-type type-info))) + (cons type (list-ref args index))))))))) + (arg-info (arg-info-looper 0 '())) + (arg-cbv (make-c-bytevector 1024)) + (arg-cbv-offset 0) + (invoke-error (c-bytevector-null)) + (return-value (make-c-bytevector 1024))) + (for-each + (lambda (arg) + (c-bytevector-set! arg-cbv + (car arg) + arg-cbv-offset + (if (string? (cdr arg)) + (string->c-bytevector (cdr arg)) + (cdr arg))) + (set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (car arg))))) + arg-info) + (c-gi-function-info-invoke method-info + arg-cbv + n-args + (c-bytevector-null) + 0 + return-value + invoke-error) + (display "HERE: return-type ") + (write return-type) + (newline) + return-value)) + + + + + +(define (gi-repository-find-by-name repository namespace name) + (let ((base-info + (c-gi-repository-find-by-name repository + (string->c-bytevector namespace) + (string->c-bytevector name)))) + (when (c-bytevector-null? base-info) + (c-perror (string->c-bytevector "(C perror) find-gi-function")) + (error "find-gi-function: ERROR" namespace name base-info)) + base-info)) + +(define (gi-invoke function-info argv argc return-type) + (let ((return-value (make-c-bytevector 1024)) + (invoke-error (c-bytevector-null))) + (c-gi-function-info-invoke function-info + argv + argc + (c-bytevector-null) + 0 + return-value + invoke-error) + (c-bytevector-ref return-value return-type 0))) diff --git a/retropikzel/gi-repository.sld b/retropikzel/gi-repository.sld index ee99592..ae81eb9 100644 --- a/retropikzel/gi-repository.sld +++ b/retropikzel/gi-repository.sld @@ -3,8 +3,11 @@ (import (scheme base) (scheme write) (foreign c)) - (export gi-repository-new - gi-repository-require - gi-repository-find-by-name - gi-function-info-invoke) + (export gi-repository + gi-object + gi-object-namespace + gi-object-name + gi-object-invoke + + ) (include "gi-repository.scm")) diff --git a/retropikzel/gi-repository/test.scm b/retropikzel/gi-repository/test.scm index 0dceca1..99a7c2f 100644 --- a/retropikzel/gi-repository/test.scm +++ b/retropikzel/gi-repository/test.scm @@ -1,55 +1,71 @@ -(test-begin "gi-repository") +;(test-begin "gi-repository") -(define repository (gi-repository-new)) -(display repository) +(define gtk (gi-repository "Gtk" "3.0")) +(define gtk-application (gi-object gtk "Gtk" "Application")) +(define app (gi-object-invoke gtk-application "new" "org.hello.world" 0)) + +(display "HERE: ") +(write app) (newline) -(define err (make-c-null)) -(call-with-address-of - err - (lambda (err-address) - (gi-repository-require repository - (string->c-utf8 "GLib") - (string->c-utf8 "2.0") +#| +(define gtk (load-gi-repository "Gtk" "3.0")) +(define gtk-application (gi-repository-find-by-name gtk "Gtk" "Application")) +(display "HERE: gtk-application ") +(write (gi-info-namespace gtk-application)) +(newline) +(write (gi-info-name gtk-application)) +(newline) + +(define gtk-application-new (gi-object-info-find-method gtk-application "new")) +(display "HERE: gtk-application-new ") +(write (gi-info-namespace gtk-application-new)) +(newline) +(write (gi-info-name gtk-application-new)) +(newline) + +(define app + (let ((args (make-c-bytevector 1024))) + (c-bytevector-set! args 'pointer 0 (c-bytevector-null)) + (c-bytevector-set! args 'int (c-type-size 'pointer) 0) + (gi-invoke gtk-application-new args 2 'pointer))) + +(write app) +(newline) + +(define gtk-application-window (gi-repository-find-by-name gtk "Gtk" "ApplicationWindow")) +;(define gtk-application-window-new (gi-object-info-find-method gtk-application-window "new")) +(display "HERE: gtk-application-window ") +(write (gi-info-namespace gtk-application-window)) +(newline) +(write (gi-info-name gtk-application-window)) +(newline) + +(define gtk-application-window-new (gi-object-info-find-method gtk-application-window "new")) +(display "HERE: gtk-application-window-new ") +(write (gi-info-namespace gtk-application-window-new)) +(newline) +(write (gi-info-name gtk-application-window-new)) +(newline) + +(define window + (let ((args (make-c-bytevector 1024))) + (c-bytevector-set! args 'pointer 0 app) + (gi-invoke gtk-application-window-new args 1 'pointer))) + +(write window) +(newline) + +#;(define return-code + (c-gi-function-info-invoke gtk-application-new + args + 2 + (c-bytevector-null) 0 - err-address) - (when (not (c-null? err)) - (error "gi-repository-require failed")))) + app-return-value + invoke-error)) - -(define base-info - (gi-repository-find-by-name repository - (string->c-utf8 "GLib") - (string->c-utf8 "assertion_message"))) - -(when (c-null? base-info) (error "base-info failed")) - -(define args (make-c-bytevector (* (c-type-size 'pointer) 5))) - -(c-bytevector-pointer-set! args 0 (string->c-utf8 "domain")) -(c-bytevector-pointer-set! args (c-type-size 'pointer) (string->c-utf8 "(retropikzel gi-repository)")) -(c-bytevector-u8-set! args (* (c-type-size 'pointer) 2) 42) -(c-bytevector-pointer-set! args (* (c-type-size 'pointer) 3) (string->c-utf8 "test.scm")) -(c-bytevector-pointer-set! args (* (c-type-size 'pointer) 4) (string->c-utf8 "foobar")) - -(define return-value (make-c-bytevector (c-type-size 'int))) -(define invoke-err (make-c-null)) -(call-with-address-of - invoke-err - (lambda (invoke-err-address) - (let ((return-code - (gi-function-info-invoke base-info - args - 5 - (make-c-null) - 0 - (make-c-null) - invoke-err-address))) - (display "HERE: ") - (write return-code) - (newline) - ))) - -(test-end "gi-repository") +;|# +;(test-end "gi-repository")