From f507ff1059647a6ee717d316586bb6cf12b68192 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sun, 29 Mar 2026 16:58:56 +0300 Subject: [PATCH] Backup --- retropikzel/gi-repository.scm | 405 ++++++++++++++++++++++++----- retropikzel/gi-repository.sld | 13 + retropikzel/gi-repository/test.scm | 89 +++---- 3 files changed, 378 insertions(+), 129 deletions(-) diff --git a/retropikzel/gi-repository.scm b/retropikzel/gi-repository.scm index 17e4258..8564c46 100644 --- a/retropikzel/gi-repository.scm +++ b/retropikzel/gi-repository.scm @@ -7,9 +7,12 @@ '((additional-versions ("0")))) + (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-repository-c-prefix c-gi 'gi_repository_get_c_prefix 'pointer '(pointer pointer)) +(define-c-procedure c-gi-repository-get-loaded-namespaces c-gi 'gi_repository_get_loaded_namespaces '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)) @@ -28,14 +31,80 @@ (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-struct-info-find-method c-gi 'gi_struct_info_find_method 'pointer '(pointer pointer)) (define-c-procedure c-gi-object-info-find-method c-gi 'gi_object_info_find_method 'pointer '(pointer pointer)) +(define-c-procedure c-gi-object-info-find-signal c-gi 'gi_object_info_find_signal 'pointer '(pointer pointer)) (define-c-struct-type gerror '((domain u32) (code int) (message pointer))) +(define GI-TYPE-TAG-VOID 0) +(define GI-TYPE-TAG-BOOLEAN 1) +(define GI-TYPE-TAG-INT8 2) +(define GI-TYPE-TAG-UINT8 3) +(define GI-TYPE-TAG-INT16 4) +(define GI-TYPE-TAG-UINT16 5) +(define GI-TYPE-TAG-INT32 6) +(define GI-TYPE-TAG-UINT32 7) +(define GI-TYPE-TAG-INT64 8) +(define GI-TYPE-TAG-UINT64 9) +(define GI-TYPE-TAG-FLOAT 10) +(define GI-TYPE-TAG-DOUBLE 11) +(define GI-TYPE-TAG-GTYPE 12) (define GI-TYPE-TAG-UTF8 13) +(define GI-TYPE-TAG-FILENAME 14) +(define GI-TYPE-TAG-ARRAY 15) (define GI-TYPE-TAG-INTERFACE 16) +(define GI-TYPE-TAG-GLIST 17) +(define GI-TYPE-TAG-GSLIST 18) +(define GI-TYPE-TAG-GHASH 19) +(define GI-TYPE-TAG-ERROR 20) +(define GI-TYPE-TAG-UNICHAR 21) + +(define (gi-type->foreign-c-type type-info) + (let* ((tag (c-gi-type-info-get-tag type-info)) + (result (cond ((= tag GI-TYPE-TAG-VOID) + ;; FIXME + 'callback) + ((= tag GI-TYPE-TAG-BOOLEAN) 'int) + ((= tag GI-TYPE-TAG-INT8) 'i8) + ((= tag GI-TYPE-TAG-UINT8) 'u8) + ((= tag GI-TYPE-TAG-INT16) 'i16) + ((= tag GI-TYPE-TAG-UINT16) 'u16) + ((= tag GI-TYPE-TAG-INT32) 'i32) + ((= tag GI-TYPE-TAG-UINT32) 'u32) + ((= tag GI-TYPE-TAG-INT64) 'i64) + ((= tag GI-TYPE-TAG-UINT64) 'u64) + ((= tag GI-TYPE-TAG-FLOAT) 'float) + ((= tag GI-TYPE-TAG-DOUBLE) 'double) + ((= tag GI-TYPE-TAG-GTYPE) 'int) + ((= tag GI-TYPE-TAG-UTF8) 'pointer) + ((= tag GI-TYPE-TAG-FILENAME) 'pointer) + ((= tag GI-TYPE-TAG-ARRAY) 'pointer) + ((= tag GI-TYPE-TAG-INTERFACE) + ;(display "HERE: interface name ") + ;(write (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info)))) + ;(newline) + ;; FIXME Read type from type-info somehow + (cond ((or + (string=? (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))) "ApplicationFlags") + (string=? (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info))) "WindowType")) + 'int) + (else 'pointer))) + ((= tag GI-TYPE-TAG-GLIST) 'pointer) + ((= tag GI-TYPE-TAG-GSLIST) 'pointer) + ((= tag GI-TYPE-TAG-GHASH) 'pointer) + ((= tag GI-TYPE-TAG-ERROR) 'pointer) + ((= tag GI-TYPE-TAG-UNICHAR) 'int) + (else (error "gi-type->foreign-c-type: Unknown gi-type" + (c-bytevector->string (c-gi-base-info-get-name (c-gi-type-info-get-interface type-info)))))))) + result)) + +(define-record-type + (make-gi-repository name cbv) + gi-repository? + (name gi-repository-name) + (cbv gi-repository-cbv)) (define (gi-repository name version) (let ((repository (c-gi-repository-new)) @@ -49,74 +118,117 @@ 0 err-address))) (when (not (c-bytevector-null? err)) - (let* ((error-list (c-bytevector->list pointer gerror)) + (let* ((error-list (c-bytevector->list err 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)) + (make-gi-repository name 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-repository-info repository) + (let* + ((cbv (gi-repository-cbv repository)) + (c-prefix (c-bytevector->string + (c-gi-repository-c-prefix cbv + (string->c-bytevector + (gi-repository-name repository))))) + (loaded-namespaces + (letrec* ((count-cbv (make-c-bytevector (c-type-size 'int))) + (namespaces (c-gi-repository-get-loaded-namespaces cbv count-cbv)) + (count (c-bytevector-ref count-cbv 'int 0)) + (looper + (lambda (index result) + (if (= index count) + result + (looper (+ index 1) + (append result + (list + (c-bytevector->string (c-bytevector-ref namespaces + 'pointer + (* (c-type-size 'pointer) index)))))))))) + (looper 0 '()) + )) + ) + `((c-prefix . ,c-prefix) + (loaded-namespaces . ,loaded-namespaces) + ))) -(define (gi-info-namespace info) - (c-bytevector->string (c-gi-base-info-get-namespace info))) -(define gi-object-namespace gi-info-namespace) +(define (gi-function-info repository function-name) + (let ((info (c-gi-repository-find-by-name + (gi-repository-cbv repository) + (string->c-bytevector (gi-repository-name repository)) + (string->c-bytevector function-name)))) + (if (c-bytevector-null? info) + #f + (letrec* + ((return-info (c-gi-callable-info-get-return-type info)) + (return-type (gi-type->foreign-c-type return-info)) + (argument-count (c-gi-callable-info-get-n-args info)) + (argument-types-loop + (lambda (index result) + (if (= index argument-count) + result + (argument-types-loop + (+ index 1) + (append + result + (list + (let* ((arg-info (c-gi-callable-info-get-arg info index)) + (type-info (c-gi-arg-info-get-type-info arg-info)) + (type (gi-type->foreign-c-type type-info))) + `((type . ,type) + (index . ,index))))))))) + (argument-types (argument-types-loop 0 '()))) + `((namespace . ,(gi-repository-name repository)) + (function-name . ,function-name) + (return-type . ,return-type) + (argument-count . ,argument-count) + (argument-types . ,argument-types) + (info-cbv . ,info)))))) -(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) +(define (gi-invoke repository name . args) + (when (not (gi-repository? repository)) + (error "gi-invoke: repository argument must be gi-repository" repository)) + (when (not (string? name)) + (error "gi-invoke: name argument must be string" name)) (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))) + ((function-info + (let ((function-info + (c-gi-repository-find-by-name + (gi-repository-cbv repository) + (string->c-bytevector (gi-repository-name repository)) + (string->c-bytevector name)))) + (when (c-bytevector-null? function-info) + (error "gi-invoke: Repository has not function" + (gi-repository-name repository) + name)) + function-info)) + (function-return-info (c-gi-callable-info-get-return-type function-info)) + (return-type (gi-type->foreign-c-type function-return-info)) + (n-args (let ((n-args (c-gi-callable-info-get-n-args function-info))) (when (not (= n-args (length args))) (error - (string-append "gi-object-invoke: Argument count mismatch, got " + (string-append "gi-invoke: Argument count mismatch, got " (number->string (length args)) ", wanted " (number->string n-args)) - (gi-object-namespace object) - (gi-object-name object) - method-name)) + ;(gi-object-namespace object) + ;(gi-object-name object) + name)) n-args)) (arg-info-looper (lambda (index result) - (if (= index n-args) + (if (or (= index n-args) + (= index (length args))) result (arg-info-looper (+ index 1) (append result (list - (let* ((arg-info (c-gi-callable-info-get-arg method-info index)) + (let* ((arg-info (c-gi-callable-info-get-arg function-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))))))))) @@ -135,40 +247,191 @@ (cdr arg))) (set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (car arg))))) arg-info) - (c-gi-function-info-invoke method-info + (c-gi-function-info-invoke function-info arg-cbv n-args (c-bytevector-null) 0 return-value invoke-error) - (display "HERE: return-type ") - (write return-type) - (newline) - return-value)) + (when (not (symbol=? return-type 'void)) + (c-bytevector-ref return-value return-type 0)))) - - - - -(define (gi-repository-find-by-name repository namespace name) +(define (gi-struct repository namespace name) (let ((base-info - (c-gi-repository-find-by-name repository - (string->c-bytevector namespace) - (string->c-bytevector name)))) + (c-gi-repository-find-by-name (gi-repository-cbv 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)) + (c-perror (string->c-bytevector "(C perror) gi-object")) + (error "gi-object: 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))) +(define (gi-struct-method-info struct method-name) + (let ((info (c-gi-struct-info-find-method struct (string->c-bytevector method-name)))) + (if (c-bytevector-null? info) + #f + (letrec* + ((return-info (c-gi-callable-info-get-return-type info)) + (return-type (gi-type->foreign-c-type return-info)) + (argument-count (c-gi-callable-info-get-n-args info)) + (argument-types-loop + (lambda (index result) + (if (= index argument-count) + result + (argument-types-loop + (+ index 1) + (append + result + (list + (let* ((arg-info (c-gi-callable-info-get-arg info index)) + (type-info (c-gi-arg-info-get-type-info arg-info)) + (type (gi-type->foreign-c-type type-info))) + `((type . ,type) + (index . ,index))))))))) + (argument-types (argument-types-loop 0 '()))) + `((namespace . ,(gi-info-namespace struct)) + (struct-name . ,(gi-info-name struct)) + (method-name . ,method-name) + (return-type . ,return-type) + (argument-count . ,argument-count) + (argument-types . ,argument-types) + (info-cbv . ,info)))))) + +(define (gi-struct-invoke struct method-name . args) + (let ((method-info (gi-struct-method-info struct method-name))) + (when (not method-info) + (error "gi-struct-invoke: Struct has no method" struct method-name)) + (when (not (= (cdr (assoc 'argument-count method-info)) (length args))) + (error + (string-append "gi-struct-invoke: Argument count mismatch, got " + (number->string (length args)) + ", wanted " + (number->string (cdr (assoc 'argument-count method-info)))) + (gi-struct-namespace struct) + (gi-struct-name struct) + method-name)) + (let + ((info-cbv (cdr (assoc 'info-cbv method-info))) + (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) + (let ((value (list-ref args (cdr (assoc 'index arg))))) + (c-bytevector-set! arg-cbv + (cdr (assoc 'type arg)) + arg-cbv-offset + (if (string? value) + (string->c-bytevector value) + value)) + (set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (cdr (assoc 'type arg))))))) + (cdr (assoc 'argument-types method-info))) + (c-gi-function-info-invoke info-cbv + arg-cbv + (cdr (assoc 'argument-count method-info)) + (c-bytevector-null) + 0 + return-value + invoke-error) + (if (not (symbol=? (cdr (assoc 'return-type method-info)) 'void)) + (c-bytevector-ref return-value + (cdr (assoc 'return-type method-info)) + 0))))) + +(define (gi-object repository namespace name) + (let ((base-info + (c-gi-repository-find-by-name (gi-repository-cbv 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-struct-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-struct-name gi-info-name) + +(define (gi-object-method-info object method-name) + (let ((info (c-gi-object-info-find-method object (string->c-bytevector method-name)))) + (if (c-bytevector-null? info) + #f + (letrec* + ((return-info (c-gi-callable-info-get-return-type info)) + (return-type (gi-type->foreign-c-type return-info)) + (argument-count (c-gi-callable-info-get-n-args info)) + (argument-types-loop + (lambda (index result) + (if (= index argument-count) + result + (argument-types-loop + (+ index 1) + (append + result + (list + (let* ((arg-info (c-gi-callable-info-get-arg info index)) + (type-info (c-gi-arg-info-get-type-info arg-info)) + (type (gi-type->foreign-c-type type-info))) + `((type . ,type) + (index . ,index))))))))) + (argument-types (argument-types-loop 0 '()))) + `((namespace . ,(gi-info-namespace object)) + (object-name . ,(gi-info-name object)) + (method-name . ,method-name) + (return-type . ,return-type) + (argument-count . ,argument-count) + (argument-types . ,argument-types) + (info-cbv . ,info)))))) + +(define (gi-object-invoke object method-name . args) + (let ((method-info (gi-object-method-info object method-name))) + (when (not method-info) + (error "gi-object-invoke: Object has no method" object method-name)) + (when (not (= (cdr (assoc 'argument-count method-info)) (length args))) + (error + (string-append "gi-object-invoke: Argument count mismatch, got " + (number->string (length args)) + ", wanted " + (number->string (cdr (assoc 'argument-count method-info)))) + (gi-object-namespace object) + (gi-object-name object) + method-name)) + (let + ((info-cbv (cdr (assoc 'info-cbv method-info))) + (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) + (display "HERE: arg ") + (write arg) + (newline) + (let ((value (list-ref args (cdr (assoc 'index arg))))) + (c-bytevector-set! arg-cbv + (cdr (assoc 'type arg)) + arg-cbv-offset + (if (string? value) + (string->c-bytevector value) + value)) + (set! arg-cbv-offset (+ arg-cbv-offset (c-type-size (cdr (assoc 'type arg))))))) + (cdr (assoc 'argument-types method-info))) + (c-gi-function-info-invoke info-cbv + arg-cbv + (cdr (assoc 'argument-count method-info)) + (c-bytevector-null) + 0 + return-value + invoke-error) + (if (not (symbol=? (cdr (assoc 'return-type method-info)) 'void)) + (c-bytevector-ref return-value + (cdr (assoc 'return-type method-info)) + 0))))) diff --git a/retropikzel/gi-repository.sld b/retropikzel/gi-repository.sld index ae81eb9..b57a10b 100644 --- a/retropikzel/gi-repository.sld +++ b/retropikzel/gi-repository.sld @@ -4,10 +4,23 @@ (scheme write) (foreign c)) (export gi-repository + gi-repository-info + gi-function-info + gi-invoke + + gi-struct + gi-struct-method-info + gi-struct-namespace + gi-struct-name + gi-struct-invoke + gi-object + gi-object-info gi-object-namespace gi-object-name + gi-object-method-info gi-object-invoke + gi-info-namespace ) (include "gi-repository.scm")) diff --git a/retropikzel/gi-repository/test.scm b/retropikzel/gi-repository/test.scm index 99a7c2f..25456b4 100644 --- a/retropikzel/gi-repository/test.scm +++ b/retropikzel/gi-repository/test.scm @@ -1,71 +1,44 @@ ;(test-begin "gi-repository") +(define-c-library libc '("stdlib.h" "stdio.h" "string.h" "stdio.h") #f ()) +(define-c-procedure c-puts libc 'puts 'int '(pointer)) -(define gtk (gi-repository "Gtk" "3.0")) +(define gtk (gi-repository "Gtk" "4.0")) (define gtk-application (gi-object gtk "Gtk" "Application")) +(define gtk-window (gi-object gtk "Gtk" "ApplicationWindow")) + +(define gobject (gi-repository "GObject" "2.0")) +(define gobject-object (gi-object gtk "GObject" "Object")) +(define gobject-closure (gi-struct gtk "GObject" "Closure")) + +(define gio (gi-repository "Gio" "2.0")) +(define gio-application (gi-object gio "Gio" "Application")) + (define app (gi-object-invoke gtk-application "new" "org.hello.world" 0)) -(display "HERE: ") -(write app) +;(display "HERE: method-info ") +;(write (gi-object-method-info gtk-window "new")) +;(newline) + +(define-c-callback + closure-process + 'void + '(pointer pointer int pointer pointer pointer) + (lambda (closure return-value n-param-values param-values invocation-hint marshal-data) + ;(c-puts (string->c-bytevector "HERE IN CLOSURE")) + (display "HERE: in closure") + (newline) + )) +(define closure (gi-struct-invoke gobject-closure "new_simple" 128 closure-process)) + +(gi-invoke gobject "signal_connect_closure" app "activate" closure 0) +(display "HERE: method-info ") +(write (gi-object-method-info gio-application "run")) (newline) - -#| -(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)) +(display (gi-object-invoke gio-application "run" app 0 (c-bytevector-null))) (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 - app-return-value - invoke-error)) ;|# ;(test-end "gi-repository")