diff options
| -rw-r--r-- | INSTALL | 8 | ||||
| -rw-r--r-- | NEWS | 34 | ||||
| -rw-r--r-- | README | 4 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rwxr-xr-x | examples/adw-1/adw1-demo.scm | 30 | ||||
| -rw-r--r-- | examples/adw-1/adw1-demo/dialogs.scm | 175 | ||||
| -rw-r--r-- | examples/adw-1/adw1-demo/ui/dialogs.scm | 55 | ||||
| -rw-r--r-- | examples/adw-1/adw1-demo/ui/dialogs.ui | 2 | ||||
| -rw-r--r-- | examples/adw-1/adw1-demo/ui/window.scm | 13 | ||||
| -rw-r--r-- | examples/adw-1/adw1-demo/ui/window.ui | 2 | ||||
| -rw-r--r-- | examples/adw-1/adw1-demo/window.scm | 5 | ||||
| -rw-r--r-- | g-golf/hl-api/callable.scm | 12 | ||||
| -rw-r--r-- | g-golf/hl-api/callback.scm | 178 | ||||
| -rw-r--r-- | g-golf/hl-api/ccc.scm | 4 | ||||
| -rw-r--r-- | g-golf/hl-api/closure.scm | 4 | ||||
| -rw-r--r-- | g-golf/init.scm | 22 |
16 files changed, 444 insertions, 106 deletions
@@ -69,8 +69,8 @@ Adw-1 examples: G-Golf release are [[http://ftp.gnu.org/gnu/g-golf/][here]]. The latest tarballs are: - g-golf-0.8.0-rc-1.tar.gz - g-golf-0.8.0-rc-1.tar.gz.sig + g-golf-0.8.0-rc-2.tar.gz + g-golf-0.8.0-rc-2.tar.gz.sig [ GPG Key: A3057AD7 [ gpg --keyserver keys.gnupg.net --recv-keys A3057AD7 @@ -79,8 +79,8 @@ Assuming you have satisfied the dependencies, open a terminal and proceed with the following steps: cd <download-path> - tar zxf g-golf-0.8.0-rc-1.tar.gz - cd g-golf-0.8.0-rc-1 + tar zxf g-golf-0.8.0-rc-2.tar.gz + cd g-golf-0.8.0-rc-2 ./configure [--prefix=/your/prefix] [--with-guile-site=yes] make make install @@ -26,6 +26,37 @@ warranty. * Latest News +** November 2023 + +[[http://www.gnu.org/software/g-golf][GNU G-Golf]] version 0.8.0-rc-2 is released. + +This is the second release candidate of the upcoming 0.8.0 release, now +available for testing. + +*** Noteworthy changes in 0.8.0-rc-2 + +Here is a summary of the noteworthy changes in this release. See G-Golf +[[http://git.savannah.gnu.org/cgit/g-golf.git][git summary]] and [[http://git.savannah.gnu.org/cgit/g-golf.git/log/][git log]] for a complete list and description. + +**** Examples + +Adwaita Demo + +The 'Dialogs' page has been added to the demo. + +**** Bug fixing + +emit +signal-emit + +Fixed to properly handle 'object extra arg(s) type. Prior to this fix, a +call such (emit window 'add-toast toast), with window and toast being +goops proxy instances, would raise an exception, as the extra args +handler missed a proper dispatch clause and treatment for the 'object +arg type, + +* Older News + ** October 2023 [[http://www.gnu.org/software/g-golf][GNU G-Golf]] version 0.8.0-rc-1 is released. @@ -52,9 +83,6 @@ Adwaita Demo The 'Style Classes' page has been added to the demo. - -* Older News - ** September 2023 [[http://www.gnu.org/software/g-golf][GNU G-Golf]] version 0.8.0-alpha-6 is released. @@ -81,9 +81,9 @@ points to its source code, in the G-Golf sources [[http://git.savannah.gnu.org/c ** Latest News -October 2023 +November 2023 -GNU G-Golf version 0.8.0-rc-1 released. +GNU G-Golf version 0.8.0-rc-2 released. Visit the NEWS file or see the [[http://git.savannah.gnu.org/cgit/g-golf.git/tree/NEWS][News]] page for the list of visible changes in this release, as well as older news. diff --git a/configure.ac b/configure.ac index d6ee148..de13a14 100644 --- a/configure.ac +++ b/configure.ac @@ -31,7 +31,7 @@ AC_PREREQ(2.69) AC_INIT( [g-golf], - [0.8.0-rc-1], + [0.8.0-rc-2], [bug-g-golf@gnu.org]) AC_CONFIG_AUX_DIR([build-aux]) diff --git a/examples/adw-1/adw1-demo.scm b/examples/adw-1/adw1-demo.scm index 4f3577b..485c49b 100755 --- a/examples/adw-1/adw1-demo.scm +++ b/examples/adw-1/adw1-demo.scm @@ -51,9 +51,27 @@ exec guile -e main -s "$0" "$@" (define (main args) - (let ((app (make <adw-application> - #:application-id "org.gnu.g-golf.adw1.demo"))) - (connect app 'activate show-window) - (let ((status (g-application-run app args))) - #;(exit status) - 'done))) + (letrec ((debug? (or (member "-d" args) + (member "--debug" args))) + (async-api? (or (member "-a" args) + (member "--async-api" args))) + (animate + (lambda () + (let ((app (make <adw-application> + #:application-id "org.gnu.g-golf.adw1.demo"))) + (connect app 'activate show-window) + (let ((status (g-application-run app '()))) + #;(exit status) + 'done))))) + + (cond ((and debug? async-api?) + (parameterize ((%debug #t) (%async-api #t)) + (animate))) + (debug? + (parameterize ((%debug #t)) + (animate))) + (async-api? + (parameterize ((%async-api #t)) + (animate))) + (else + (animate))))) diff --git a/examples/adw-1/adw1-demo/dialogs.scm b/examples/adw-1/adw1-demo/dialogs.scm new file mode 100644 index 0000000..2bd7add --- /dev/null +++ b/examples/adw-1/adw1-demo/dialogs.scm @@ -0,0 +1,175 @@ +;; -*- mode: scheme; coding: utf-8 -*- + +;;;; +;;;; Copyright (C) 2023 +;;;; Free Software Foundation, Inc. + +;;;; This file is part of GNU G-Golf + +;;;; GNU G-Golf is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU Lesser General Public License as +;;;; published by the Free Software Foundation; either version 3 of the +;;;; License, or (at your option) any later version. + +;;;; GNU G-Golf is distributed in the hope that it will be useful, but +;;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. + +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with GNU G-Golf. If not, see +;;;; <https://www.gnu.org/licenses/lgpl.html>. +;;;; + +;;; Commentary: + +;;; Code: + + +(define-module (adw1-demo dialogs) + #:use-module (oop goops) + #:use-module (g-golf) + + #:duplicates (merge-generics + replace + warn-override-core + warn + last) + + #:export (<adw-demo-page-dialogs>)) + + +#;(g-export ) + + +(eval-when (expand load eval) + (g-irepository-require "Gtk" #:version "4.0") + (for-each (lambda (name) + (gi-import-by-name "Gtk" name)) + '("Root" + "Button")) + (g-irepository-require "Adw" #:version "1") + (for-each (lambda (name) + (gi-import-by-name "Adw" name)) + '("Bin" + "Toast" + "ToastOverlay" + "MessageDialog" + "ResponseAppearance"))) + + +(define-class <adw-demo-page-dialogs> (<adw-bin>) + ;; slots + (dialogs-button #:child-id "dialogs-button" + #:accessor !dialogs-button) + ;; class options + #:template (string-append (dirname (current-filename)) + "/ui/dialogs.ui") + #:child-ids '("dialogs-button") + #:g-signal `(add-toast ;; name + none ;; return-type + (,<adw-toast>) ;; param-types + (run-first))) ;; signal flags + +(define-method (initialize (self <adw-demo-page-dialogs>) initargs) + (next-method) + + (connect (!dialogs-button self) + 'clicked + (lambda (b) + (demo-message-dialog-cb self))) + + (connect self + 'add-toast + (lambda (self toast) + (let* ((parent (get-root self)) + (toast-overlay (slot-ref parent 'toast-overlay))) + (add-toast toast-overlay toast))))) + +(define (demo-message-dialog-cb window) + (let* ((parent (get-root window)) + (dialog (adw-message-dialog-new parent + "Save Changes" + "Open document contains unsaved changes. Changes which are not saved will be permanently lost."))) + + (add-responses dialog + '(("cancel" "Cancel") ;; (G_ "Cancel") + ("discard" "Discard") ;; ... + ("save" "Save"))) + (set-response-appearance dialog "discard" 'destructive) + (set-response-appearance dialog "save" 'suggested) + (set-default-response dialog "save") + (set-close-response dialog "cancel") + (when (%debug) + (demo-message-dialog-cb-debug-info window parent)) + (if (%async-api) + ;; below, the user-data (last) arg should be passed to the + ;; callback, so passed to the message-cb data (last) arg - + ;; that's not happening, but i can't figure out why. whether i + ;; pass #f (NULL) or the g-inst pointer of the window goops + ;; proxy instance, the meesage-cb call always receive a valid + ;; but unknown pointer. + (choose dialog #f message-cb (!g-inst window)) + (begin + (connect dialog + 'response + (lambda (dialog response) + (response-cb dialog response window))) + (present dialog))))) + +(define (add-responses dialog responses) + (for-each (lambda (response) + (match response + ((id label) + (add-response dialog id label)))) + responses)) + +(define (message-cb dialog result data) + (let* ((response (choose-finish dialog result)) + (toast (make <adw-toast> + #:title (format #f "Dialog response: ~A" response)))) + (when (%debug) + (message-cb-debug-info dialog result data response toast)) + ;; before i can emit the signal, I need to find why the data arg is + ;; not the user-data arg of the adw-message-dialog-choose method + ;; call above (see line 106 - and a further detailed comment lines + ;; 101 - 105) - currently, uncomment would (ofc) raise an exception. + #;(emit -the-goops-proxy-inst-for-data- 'add-toast toast))) + +(define (response-cb dialog response window) + (let ((toast (make <adw-toast> + #:title (format #f "Dialog response: ~A" response)))) + (when (%debug) + (response-cb-debug-info dialog response window toast)) + (emit window 'add-toast toast))) + + +;;; +;;; *-debug-info procs +;;; + +(define (demo-message-dialog-cb-debug-info window parent) + (dimfi 'demo-message-dialog-cb) + (dimfi (format #f "~20,,,' @A:" 'window) window) + (dimfi (format #f "~20,,,' @A:" "[ g-inst") (!g-inst window) "]") + (dimfi " " '-- 'local 'variables '--) + (dimfi (format #f "~20,,,' @A:" 'parent) parent) + (dimfi (format #f "~20,,,' @A:" "[ g-inst") (!g-inst parent) "]")) + +(define (message-cb-debug-info dialog result data response toast) + (dimfi 'message-cb) + (dimfi (format #f "~20,,,' @A:" 'dialog) dialog) + (dimfi (format #f "~20,,,' @A:" 'result) result) + (dimfi (format #f "~20,,,' @A:" 'data) data) + (dimfi " " '-- 'local 'variables '--) + (dimfi (format #f "~20,,,' @A:" 'response) response) + (dimfi (format #f "~20,,,' @A:" 'toast) toast)) + +(define (response-cb-debug-info dialog response window toast) + (dimfi 'response-cb) + (dimfi (format #f "~20,,,' @A:" 'dialog) dialog) + (dimfi (format #f "~20,,,' @A:" 'response) response) + (dimfi (format #f "~20,,,' @A:" 'window) window) + (dimfi " " '-- 'local 'variable '--) + (dimfi (format #f "~20,,,' @A:" 'toast) toast) + (describe add-toast)) diff --git a/examples/adw-1/adw1-demo/ui/dialogs.scm b/examples/adw-1/adw1-demo/ui/dialogs.scm new file mode 100644 index 0000000..8b5d702 --- /dev/null +++ b/examples/adw-1/adw1-demo/ui/dialogs.scm @@ -0,0 +1,55 @@ +;; -*- mode: sxml-ui; coding: utf-8 -*- + +;;;; +;;;; Copyright (C) 2023 +;;;; Free Software Foundation, Inc. + +;;;; This file is part of GNU G-Golf + +;;;; GNU G-Golf is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU Lesser General Public License as +;;;; published by the Free Software Foundation; either version 3 of the +;;;; License, or (at your option) any later version. + +;;;; GNU G-Golf is distributed in the hope that it will be useful, but +;;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. + +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with GNU G-Golf. If not, see +;;;; <https://www.gnu.org/licenses/lgpl.html>. +;;;; + +;;; Commentary: + +;;; Code: + + +(use-modules (g-golf support sxml)) + + +(define %dialogs + `(interface + (requires (@ (version "4.0") (lib "gtk"))) + (requires (@ (version "1.0") (lib "libadwaita"))) + (template (@ (class "AdwDemoPageDialogs") + (parent "AdwBin")) + (property (@ (name "child")) + (object (@ (class "AdwStatusPage")) + (property (@ (name "icon-name")) widget-dialog-symbolic) + (property (@ (name "title") + (translatable "yes")) Dialogs) + (property (@ (name "description") + (translatable "yes")) "Adaptive dialog widgets.") + (property (@ (name "child")) + (object (@ (class "GtkButton") + (id dialogs-button)) + (property (@ (name "label") + (translatable "yes")) "Message Dialog") + (property (@ (name "halign")) center) + (style (class (@ (name "pill"))))))))))) + + +(define (make-ui) + (sxml->ui %dialogs)) diff --git a/examples/adw-1/adw1-demo/ui/dialogs.ui b/examples/adw-1/adw1-demo/ui/dialogs.ui new file mode 100644 index 0000000..881794a --- /dev/null +++ b/examples/adw-1/adw1-demo/ui/dialogs.ui @@ -0,0 +1,2 @@ +<?xml version="1.0" encoding="UTF-8"?> +<interface><requires version="4.0" lib="gtk" /><requires version="1.0" lib="libadwaita" /><template class="AdwDemoPageDialogs" parent="AdwBin"><property name="child"><object class="AdwStatusPage"><property name="icon-name">widget-dialog-symbolic</property><property name="title" translatable="yes">Dialogs</property><property name="description" translatable="yes">Adaptive dialog widgets.</property><property name="child"><object class="GtkButton" id="dialogs-button"><property name="label" translatable="yes">Message Dialog</property><property name="halign">center</property><style><class name="pill" /></style></object></property></object></property></template></interface> diff --git a/examples/adw-1/adw1-demo/ui/window.scm b/examples/adw-1/adw1-demo/ui/window.scm index 966751c..20d4a3b 100644 --- a/examples/adw-1/adw1-demo/ui/window.scm +++ b/examples/adw-1/adw1-demo/ui/window.scm @@ -80,6 +80,16 @@ (property (@ (name "child")) (object (@ (class "AdwDemoPageStyleClasses")))))) +(define %dialogs + '(object (@ (class "GtkStackPage")) + (property (@ (name "title") + (translatable "yes")) "Dialogs") + (property (@ (name "child")) + (object (@ (class "AdwDemoPageDialogs")) + ;; signal - add-toast - adw_toast_overlay_add_toast + ;; - toast-overlay - swapped + )))) + (define %sidebar `(object (@ (class "AdwNavigationPage")) (property (@ (name "title") @@ -111,7 +121,8 @@ ;; signal - notify::visible-child ... (child ,%welcome-page) (child ,%navigation-view) - (child ,%style-classes))))))) + (child ,%style-classes) + (child ,%dialogs))))))) (define %window `(interface diff --git a/examples/adw-1/adw1-demo/ui/window.ui b/examples/adw-1/adw1-demo/ui/window.ui index b78a699..754aec1 100644 --- a/examples/adw-1/adw1-demo/ui/window.ui +++ b/examples/adw-1/adw1-demo/ui/window.ui @@ -1,2 +1,2 @@ <?xml version="1.0" encoding="UTF-8"?> -<interface><requires version="4.0" lib="gtk" /><requires version="1.0" lib="libadwaita" /><menu id="primary-menu"><section><item><attribute name="label" translatable="yes">_Inspector</attribute><attribute name="action">app.inspector</attribute></item></section><section><item><attribute name="label" translatable="yes">_Preferences</attribute><attribute name="action">app.preferences</attribute></item><item><attribute name="label" translatable="yes">_About Adwaita Demo</attribute><attribute name="action">app.about</attribute></item></section></menu><template class="AdwDemoWindow" parent="AdwApplicationWindow"><property name="title" translatable="yes">Adwaita Demo</property><property name="default-width">800</property><property name="default-height">576</property><property name="width-request">360</property><property name="height-request">200</property><child><object class="AdwBreakpoint"><condition>max-width: 500sp</condition><setter object="split-view" property="collapsed">True</setter></object></child><property name="content"><object class="AdwToastOverlay" id="toast-overlay"><property name="child"><object class="AdwNavigationSplitView" id="split-view"><property name="min-sidebar-width">240</property><property name="sidebar"><object class="AdwNavigationPage"><property name="title" bind-source="AdwDemoWindow" bind-property="title" bind-flags="sync-create" /><property name="child"><object class="AdwToolbarView"><child type="top"><object class="AdwHeaderBar"><child type="start"><object class="GtkButton" id="color-scheme-button" /></child><child type="end"><object class="GtkMenuButton"><property name="tooltip-text" translatable="yes">Main Menu</property><property name="menu-model">primary-menu</property><property name="icon-name">open-menu-symbolic</property><property name="primary">True</property></object></child></object></child><property name="content"><object class="GtkStackSidebar"><property name="stack">stack</property></object></property></object></property></object></property><property name="content"><object class="AdwNavigationPage"><property name="title">Bluefox</property><property name="child"><object class="AdwToolbarView"><child type="top"><object class="AdwHeaderBar"><property name="show-title">False</property></object></child><property name="content"><object class="GtkStack" id="stack"><property name="vhomogeneous">False</property><child><object class="GtkStackPage"><property name="title" translatable="yes">Welcome</property><property name="child"><object class="AdwDemoPageWelcome" /></property></object></child><child><object class="GtkStackPage"><property name="title" translatable="yes">Navigation View</property><property name="child"><object class="AdwDemoPageNavigationView" /></property></object></child><child><object class="GtkStackPage"><property name="title" translatable="yes">Style Classes</property><property name="child"><object class="AdwDemoPageStyleClasses" /></property></object></child></object></property></object></property></object></property></object></property></object></property></template></interface> +<interface><requires version="4.0" lib="gtk" /><requires version="1.0" lib="libadwaita" /><menu id="primary-menu"><section><item><attribute name="label" translatable="yes">_Inspector</attribute><attribute name="action">app.inspector</attribute></item></section><section><item><attribute name="label" translatable="yes">_Preferences</attribute><attribute name="action">app.preferences</attribute></item><item><attribute name="label" translatable="yes">_About Adwaita Demo</attribute><attribute name="action">app.about</attribute></item></section></menu><template class="AdwDemoWindow" parent="AdwApplicationWindow"><property name="title" translatable="yes">Adwaita Demo</property><property name="default-width">800</property><property name="default-height">576</property><property name="width-request">360</property><property name="height-request">200</property><child><object class="AdwBreakpoint"><condition>max-width: 500sp</condition><setter object="split-view" property="collapsed">True</setter></object></child><property name="content"><object class="AdwToastOverlay" id="toast-overlay"><property name="child"><object class="AdwNavigationSplitView" id="split-view"><property name="min-sidebar-width">240</property><property name="sidebar"><object class="AdwNavigationPage"><property name="title" bind-source="AdwDemoWindow" bind-property="title" bind-flags="sync-create" /><property name="child"><object class="AdwToolbarView"><child type="top"><object class="AdwHeaderBar"><child type="start"><object class="GtkButton" id="color-scheme-button" /></child><child type="end"><object class="GtkMenuButton"><property name="tooltip-text" translatable="yes">Main Menu</property><property name="menu-model">primary-menu</property><property name="icon-name">open-menu-symbolic</property><property name="primary">True</property></object></child></object></child><property name="content"><object class="GtkStackSidebar"><property name="stack">stack</property></object></property></object></property></object></property><property name="content"><object class="AdwNavigationPage"><property name="title">Bluefox</property><property name="child"><object class="AdwToolbarView"><child type="top"><object class="AdwHeaderBar"><property name="show-title">False</property></object></child><property name="content"><object class="GtkStack" id="stack"><property name="vhomogeneous">False</property><child><object class="GtkStackPage"><property name="title" translatable="yes">Welcome</property><property name="child"><object class="AdwDemoPageWelcome" /></property></object></child><child><object class="GtkStackPage"><property name="title" translatable="yes">Navigation View</property><property name="child"><object class="AdwDemoPageNavigationView" /></property></object></child><child><object class="GtkStackPage"><property name="title" translatable="yes">Style Classes</property><property name="child"><object class="AdwDemoPageStyleClasses" /></property></object></child><child><object class="GtkStackPage"><property name="title" translatable="yes">Dialogs</property><property name="child"><object class="AdwDemoPageDialogs" /></property></object></child></object></property></object></property></object></property></object></property></object></property></template></interface> diff --git a/examples/adw-1/adw1-demo/window.scm b/examples/adw-1/adw1-demo/window.scm index 4a284d0..3734841 100644 --- a/examples/adw-1/adw1-demo/window.scm +++ b/examples/adw-1/adw1-demo/window.scm @@ -34,6 +34,7 @@ #:use-module (adw1-demo welcome) #:use-module (adw1-demo navigation-view) #:use-module (adw1-demo style-classes) + #:use-module (adw1-demo dialogs) #:duplicates (merge-generics replace @@ -81,13 +82,15 @@ (define-class <adw-demo-window> (<adw-application-window>) ;; slots + (toast-overlay #:accessor !toast-overlay #:child-id "toast-overlay") (split-view #:accessor !split-view #:child-id "split-view") (color-scheme-button #:accessor !color-scheme-button #:child-id "color-scheme-button") (stack #:accessor !stack #:child-id "stack") ;; class options #:template (string-append (dirname (current-filename)) "/ui/window.ui") - #:child-ids '("split-view" + #:child-ids '("toast-overlay" + "split-view" "color-scheme-button" "stack")) diff --git a/g-golf/hl-api/callable.scm b/g-golf/hl-api/callable.scm index eabf44c..f795597 100644 --- a/g-golf/hl-api/callable.scm +++ b/g-golf/hl-api/callable.scm @@ -27,6 +27,7 @@ (define-module (g-golf hl-api callable) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (oop goops) @@ -355,6 +356,8 @@ (memq name %allow-none-exceptions)) (define (callable-prepare-gi-args-in callable args) + (when (%debug) + (dimfi (!name callable))) (let ((is-method? (!is-method? callable))) (let loop ((arguments (!args-in callable))) (match arguments @@ -374,6 +377,15 @@ #:may-be-null-acc !may-be-null? #:is-method? is-method? #:forced-type (!forced-type argument)) + (when (%debug) + (dimfi (format #f "~20,,,' @A:" (!name argument)) value + #;(gi-argument->scm (!type-tag argument) + (!type-desc argument) + gi-argument- + arguments + ;; #:forced-type (!forced-type argument) + #:is-pointer? (!is-pointer? argument) + ))) (loop rest))))))) (define* (scm->gi-argument type-tag diff --git a/g-golf/hl-api/callback.scm b/g-golf/hl-api/callback.scm index c4826bb..1019c30 100644 --- a/g-golf/hl-api/callback.scm +++ b/g-golf/hl-api/callback.scm @@ -29,6 +29,7 @@ (define-module (g-golf hl-api callback) #:use-module (system foreign) #:use-module (ice-9 threads) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (srfi srfi-1) @@ -81,7 +82,7 @@ (g-name (g-base-info-get-name info)) (name (g-name->name g-name))) (when (%debug) - (dimfi 'import-callback namespace name)) + (dimfi " [" 'importing: namespace name "]")) (or (gi-callback-inst-cache-ref name) (let ((callback (make <callback> #:info info #:namespace namespace @@ -107,38 +108,42 @@ `(#:namespace ,namespace #:g-name ,g-name #:name ,name))))) - (mslot-set! self - 'ffi-cif (callback-ffi-cif self)))) + (receive (ffi-cif-bv ffi-cif) + (callback-ffi-cif self) + (mslot-set! self + 'ffi-cif-bv ffi-cif-bv + 'ffi-cif ffi-cif)))) -(define (ffi-prep-cif-elements callback) +(define (ffi-prep-cif-elements callback n-arg) (let* ((ffi-cif-bv (make-bytevector (ffi-cif-size) 0)) (r-type-info (g-callable-info-get-return-type (!info callback))) (r-type (g-type-info-get-ffi-type r-type-info)) - (n-arg (!n-arg callback)) (a-types-bv (make-bytevector (* n-arg (ffi-type-size)) 0))) (g-base-info-unref r-type-info) - (values (bytevector->pointer ffi-cif-bv) - n-arg + (values ffi-cif-bv + (bytevector->pointer ffi-cif-bv) r-type + a-types-bv (bytevector->pointer a-types-bv)))) (define (callback-ffi-cif callback) - (receive (ffi-cif n-arg r-type a-types) - (ffi-prep-cif-elements callback) + (let ((n-arg (!n-arg callback))) (if (= n-arg 0) - %null-pointer - (let loop ((arguments (!arguments callback)) - (w-ptr a-types)) - (match arguments - (() - (ffi-prep-cif ffi-cif n-arg r-type a-types) - ffi-cif) - ((argument . rest) - (bv-ptr-set! w-ptr - (gi-type-tag-get-ffi-type (!type-tag argument) - (!is-pointer? argument))) - (loop rest - (gi-pointer-inc w-ptr)))))))) + (values #f %null-pointer) + (receive (ffi-cif-bv ffi-cif r-type a-types-bv a-types) + (ffi-prep-cif-elements callback n-arg) + (let loop ((arguments (!arguments callback)) + (w-ptr a-types)) + (match arguments + (() + (ffi-prep-cif ffi-cif n-arg r-type a-types) + (values ffi-cif-bv ffi-cif)) + ((argument . rest) + (bv-ptr-set! w-ptr + (gi-type-tag-get-ffi-type (!type-tag argument) + (!is-pointer? argument))) + (loop rest + (gi-pointer-inc w-ptr))))))))) (define (g-callable-info-make-closure info ffi-cif @@ -162,19 +167,16 @@ return-value ffi-args user-data) - (let* ((%gi-argument->scm - (@ (g-golf hl-api callable) gi-argument->scm)) - (%scm->gi-argument + (let* ((%scm->gi-argument (@ (g-golf hl-api callable) scm->gi-argument)) (callback-closure (pointer->scm user-data)) (callback (!callback callback-closure)) (procedure (!procedure callback-closure)) - (g-value-ptr? (preserve-g-value-ptr? callback)) (return-type (!return-type callback)) (gi-argument (!gi-arg-result callback))) (when (%debug) (dimfi 'g-golf-callback-closure-marshal) - (dimfi " " (!name callback))) + (dimfi " " (!name callback))) (let loop ((arguments (!arguments callback)) (ffi-arg ffi-args) (args '())) @@ -184,14 +186,12 @@ (case return-type ((void) (when (%debug) - (dimfi " arguments:" args) - (dimfi " return-value: void")) + (dimfi " returned value: void")) (apply procedure args)) (else (let ((r-val (apply procedure args))) (when (%debug) - (dimfi " arguments:" args) - (dimfi " return-value:" r-val)) + (dimfi " returned value:" r-val)) (%scm->gi-argument return-type (!type-desc callback) return-value @@ -202,62 +202,12 @@ #:is-method? (!is-method? callback) #:forced-type return-type)))))) ((argument . rests) - (let* ((type-tag (!type-tag argument)) - (type-desc (!type-desc argument)) - (is-pointer? (!is-pointer? argument)) - (is-enum? (!is-enum? argument)) - (gi-argument (or (!gi-argument-in argument) - (!gi-argument-out argument))) - (forced-type (!forced-type argument)) - (ffi-value (ffi-arg->scm ffi-arg type-tag is-pointer? is-enum?))) + (let ((value (ffi-arg->cb-arg callback argument ffi-arg))) + (when (%debug) + (dimfi (format #f "~20,,,' @A:" (!name argument)) value)) (loop rests (gi-pointer-inc ffi-arg) - (cons (case type-tag - ((boolean - int8 - uint8 - int16 - uint16 - int32 - uint32 - unichar - int64 - uint64 - float - double - gtype - utf8 - filename) - ffi-value) - ((array - glist - gslist - ghash - error) - (begin - (gi-argument-set! gi-argument 'v-pointer ffi-value) - (%gi-argument->scm type-tag - type-desc - gi-argument - argument - #:forced-type forced-type - #:is-pointer? is-pointer?))) - ((interface) - (if is-enum? - (gi-argument-set! gi-argument 'v-int32 ffi-value) - (gi-argument-set! gi-argument 'v-pointer ffi-value)) - (%gi-argument->scm type-tag - type-desc - gi-argument - argument - #:forced-type forced-type - #:is-pointer? is-pointer? - #:g-value-ptr? g-value-ptr?)) - ((void) - (if is-pointer? - ffi-value - (error "unlikely possible")))) - args)))))))) + (cons value args)))))))) (define %g-golf-callback-closure-marshal (procedure->pointer void @@ -278,6 +228,64 @@ (scm->pointer callback-closure)) callback-closure))) +(define (ffi-arg->cb-arg callback argument ffi-arg) + (let* ((%gi-argument->scm + (@ (g-golf hl-api callable) gi-argument->scm)) + (g-value-ptr? (preserve-g-value-ptr? callback)) + (type-tag (!type-tag argument)) + (type-desc (!type-desc argument)) + (is-pointer? (!is-pointer? argument)) + (is-enum? (!is-enum? argument)) + (gi-argument (or (!gi-argument-in argument) + (!gi-argument-out argument))) + (forced-type (!forced-type argument)) + (ffi-value (ffi-arg->scm ffi-arg type-tag is-pointer? is-enum?))) + (case type-tag + ((boolean + int8 + uint8 + int16 + uint16 + int32 + uint32 + unichar + int64 + uint64 + float + double + gtype + utf8 + filename) + ffi-value) + ((array + glist + gslist + ghash + error) + (begin + (gi-argument-set! gi-argument 'v-pointer ffi-value) + (%gi-argument->scm type-tag + type-desc + gi-argument + argument + #:forced-type forced-type + #:is-pointer? is-pointer?))) + ((interface) + (if is-enum? + (gi-argument-set! gi-argument 'v-int32 ffi-value) + (gi-argument-set! gi-argument 'v-pointer ffi-value)) + (%gi-argument->scm type-tag + type-desc + gi-argument + argument + #:forced-type forced-type + #:is-pointer? is-pointer? + #:g-value-ptr? g-value-ptr?)) + ((void) + (if is-pointer? + ffi-value + (error "unlikely possible")))))) + ;;; ;;; The gi-callback-inst-cache diff --git a/g-golf/hl-api/ccc.scm b/g-golf/hl-api/ccc.scm index 26ad431..0216a8b 100644 --- a/g-golf/hl-api/ccc.scm +++ b/g-golf/hl-api/ccc.scm @@ -79,7 +79,8 @@ !gi-args-out-bv !gi-arg-result - !ffi-cif ;; callback + !ffi-cif-bv ;; callback + !ffi-cif !callback ;; callback-closure !procedure) @@ -125,6 +126,7 @@ ;;; (define-class <callback> (<callable>) + (ffi-cif-bv #:accessor !ffi-cif-bv) (ffi-cif #:accessor !ffi-cif)) diff --git a/g-golf/hl-api/closure.scm b/g-golf/hl-api/closure.scm index fb665ca..d47e01f 100644 --- a/g-golf/hl-api/closure.scm +++ b/g-golf/hl-api/closure.scm @@ -201,6 +201,10 @@ (g-value-set! g-value (scm->gi val 'pointer))) #;((boxed)) #;((param)) + ((eq? type 'object) + (let ((g-type (!g-type (class-of val)))) + (%g_value_init g-value g-type) + (g-value-set! g-value (!g-inst val)))) ((gobject-class? type) (%g_value_init g-value (!g-type type)) (g-value-set! g-value (!g-inst val))) diff --git a/g-golf/init.scm b/g-golf/init.scm index efcf129..5f64297 100644 --- a/g-golf/init.scm +++ b/g-golf/init.scm @@ -35,7 +35,9 @@ %libg-golf %debug - %iface-vfunc-warnings)) + %iface-vfunc-warnings + + %async-api)) (define %libgirepository (dynamic-link "libgirepository-1.0")) @@ -47,3 +49,21 @@ (define %debug (make-parameter #f)) (define %iface-vfunc-warnings (make-parameter #f)) + +;; The AdwMessageDialog class offers two ways to capture the user +;; response: (1) the traditional dialog 'response signal callback and +;; (2) the Gio Async API. + +;; For some misterious reason (still), I couldn't (yet) make the Gio +;; Async API approach work. See the commit dc9ff1f as well as the +;; comments in the (adw1-demo dialogs) module for a detailed description +;; of the problem. + +;; Till I or someone else figures out what's going on and how to fix it, +;; I'll swith to use the dialog 'response signal callback model, but to +;; be able to later track and possibly fix this problem, I add this +;; parameter, that together with the ./examples/adw-1/adw1-demo.scm -a, +;; --async-api command line option, allows the (adw1-demo dialogs) to +;; implement and selectively switch to one response model or the other. + +(define %async-api (make-parameter #f)) |