diff options
| author | David Pirotte <david@altosw.be> | 2023-04-16 19:16:32 -0300 |
|---|---|---|
| committer | David Pirotte <david@altosw.be> | 2023-04-16 19:16:32 -0300 |
| commit | 5d7c6a5da116302cc0d8c4f1ab19a2bb2085ea10 (patch) | |
| tree | 962e431bac41d4c9160a5c6e12a54347bdb60946 | |
| parent | a4e9fc569cd7968896358518e8c23747cefffcc9 (diff) | |
| parent | 3e51b5405b18b8fe762bb98c4cb65adda5fda8e8 (diff) | |
Prepare 0.8.0-a.4v0.8.0-a.4
28 files changed, 899 insertions, 135 deletions
@@ -23,7 +23,9 @@ Gnome: (Guile Object Library for) ** Dependencies -GNU G-Golf needs the following software to run: +*** Main Dependencies + +G-Golf needs the following software to run: Autoconf >= 2.69 Automake >= 1.14 @@ -35,12 +37,32 @@ GNU G-Golf needs the following software to run: Gobject-2.0 >= 2.48.0 GObject-Introspection-1.0 >= 1.72.0 +*** Test-Suite Dependencies + +G-Golf currently needs the following additional +software to run its test-suite: + + Clutter-1.0 >= 1.24.0 + Gtk-3.0 >= 3.10.0 + +*** Examples Dependencies + +G-Golf currently needs the following additional software to run its +examples: + + Gtk-4.0 >= 4.10.0 + Guile-Cairo > 1.11.2 + + G-Golf actually requires a patched version of guile-cairo that + contains the following new interface (which is not in guile-cairo + 1.11.2): cairo-pointer->context + ** Install from the tarball G-Golf release are [[http://ftp.gnu.org/gnu/g-golf/][here]]. The latest tarballs are: - g-golf-0.8.0-a.3.tar.gz - g-golf-0.8.0-a.3.tar.gz.sig + g-golf-0.8.0-a.4.tar.gz + g-golf-0.8.0-a.4.tar.gz.sig [ GPG Key: A3057AD7 [ gpg --keyserver keys.gnupg.net --recv-keys A3057AD7 @@ -49,8 +71,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-a.3.tar.gz - cd g-golf-0.8.0-a.3 + tar zxf g-golf-0.8.0-a.4.tar.gz + cd g-golf-0.8.0-a.4 ./configure [--prefix=/your/prefix] [--with-guile-site=yes] make make install @@ -26,6 +26,49 @@ warranty. * Latest News +** April 2023 + +[[http://www.gnu.org/software/g-golf][GNU G-Golf]] version 0.8.0-a.4 is released. + +This is the fourth release of the upcoming 0.8.0 release, now available +for testing. + +*** Changes since 0.8.0-a.3 + +Here is a summary of the noteworthy changes since version 0.8.0-a.3. 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. + +**** New features + +Next-vfunc + + This release adds full support for a next-vfunc mechanism - which is + to the GObject virtual method system what the next-method concept and + mechanism is to the GOOPS (compute applicable) method system. + +**** Examples + +Simple Paintable +Animated Paintable + + New examples. Please note that these examples requires + [[https://www.nongnu.org/guile-cairo/][guile-cairo]]. They actually requires a patched version of guile-cairo + that contains the following new interface (which is not in guile-cairo + 1.11.2): + + cairo-pointer->context + +**** Bug fixing + +Missing <gobject> g-struct-fields + + At (load eval) time, the (g-golf defined) <gobject> class must be + completed: retreive the class-struct and fill the <gobject> + g-struct-fields slot - used by the vfunc mechanism. + + +* Older News + ** February 2023 [[http://www.gnu.org/software/g-golf][GNU G-Golf]] version 0.8.0-a.3 is released. @@ -94,9 +137,6 @@ bug fixed its snapshot-vfunc method. More specifically its width and height argument values are now correct, we no longer need to explicitly call get-intrinsic-width and get-intrinsic-height. - -* Older News - ** January 2023 [[http://www.gnu.org/software/g-golf][GNU G-Golf]] version 0.8.0-a.2 is released. @@ -81,9 +81,9 @@ points to its source code, in the G-Golf sources [[http://git.savannah.gnu.org/c ** Latest News -February 2023 +April 2023 -GNU G-Golf version 0.8.0-a.3 is released. +GNU G-Golf version 0.8.0-a.4 is 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 since the last release, as well as older news. diff --git a/am/guile.mk b/am/guile.mk index 5e23d93..e8434da 100644 --- a/am/guile.mk +++ b/am/guile.mk @@ -1,6 +1,6 @@ #### -#### Copyright (C) 2016 - 2020 +#### Copyright (C) 2016 - 2023 #### Free Software Foundation, Inc. #### This file is part of GNU G-Golf @@ -48,5 +48,5 @@ GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat SUFFIXES = .scm .go .scm.go: - $(AM_V_GEN)$(top_builddir)/pre-inst-env \ + $(AM_V_GEN) $(top_builddir)/pre-inst-env \ $(GUILD) compile $(GUILE_WARNINGS) -o "$@" "$<" diff --git a/configure.ac b/configure.ac index 65a049a..6a40cf0 100644 --- a/configure.ac +++ b/configure.ac @@ -31,7 +31,7 @@ AC_PREREQ(2.69) AC_INIT( [g-golf], - [0.8.0-a.3], + [0.8.0-a.4], [bug-g-golf@gnu.org]) AC_CONFIG_AUX_DIR([build-aux]) diff --git a/doc/cr-gi-callable-info.texi b/doc/cr-gi-callable-info.texi index 9d29bb3..2783291 100644 --- a/doc/cr-gi-callable-info.texi +++ b/doc/cr-gi-callable-info.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2016 - 2020 Free Software Foundation, Inc. +@c Copyright (C) 2016 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -18,11 +18,13 @@ GICallableInfo — Struct representing a callable. @indentedblock @table @code +@item @ref{g-callable-info-can-throw-gerror} @item @ref{g-callable-info-get-n-args} @item @ref{g-callable-info-get-arg} @item @ref{g-callable-info-get-caller-owns} @item @ref{g-callable-info-get-instance-ownership-transfer} @item @ref{g-callable-info-get-return-type} +@item @ref{g-callable-info-invoke} @item @ref{g-callable-info-is-method} @item @ref{g-callable-info-may-return-null} @item @ref{g-callable-info-create-closure} @@ -67,6 +69,14 @@ Note: in this section, the @var{info} argument is [must be] a pointer to a @code{GICallableInfo}. +@anchor{g-callable-info-can-throw-gerror} +@deffn Procedure g-callable-info-can-throw-gerror info + +Returns @code{#t} if the callable @var{info} can throw a GError, +otherwise it returns @code{#f}. +@end deffn + + @anchor{g-callable-info-get-n-args} @deffn Procedure g-callable-info-get-n-args info @@ -117,6 +127,61 @@ the data. @end deffn +@anchor{g-callable-info-invoke} +@deffn Procedure g-callable-info-invoke info function in-args n-in @ + out-args n-out r-val is-method throws g-error + +Returns @code{#t} if the function has been invoked, @code{#f} if an +error occured. + +Invokes the function described in @var{info} with the given +arguments. Note that i@code{nout} parameters must appear in both +argument lists. The arguments are: + +@indentedblock +@table @code +@item @emph{info} +a pointer to a @code{GIFunctionInfo} describing the function to invoke. + +@item @emph{function} +a pointer to the function to invoke. + +@item @emph{in-args} +a pointer to an array of @code{GIArguments}, one for each @code{in} and +@code{inout} parameter of @var{info}. If there are no @code{in} +parameter, @var{in-args} must be the @code{%null-pointer}. + +@item @emph{n-in} +the length of the @var{in-args} array. + +@item @emph{out-args} +a pointer to an array of @code{GIArguments}, one for each @code{out} and +@code{inout} parameter of @var{info}. If there are no @code{out} +parameter, @var{out-args} must be the @code{%null-pointer}. + +@item @emph{n-out} +the length of the @var{out-args} array. + +@item @emph{r-val} +a pointer to a @code{GIArguments}, the return location for the return +value of the function. If the function returns @code{void}, @var{r-val} +must be the @code{%null-pointer}. + +@item @emph{is-method} +is the callable info is a method. + +@item @emph{throws} +can the callable throw a @code{GError}. + +@item @emph{g-error} +a pointer to a newly allocated (and @samp{empty}) @code{GError} (the +recommended way for procedure calls that need such a pointer is to +@samp{surround} the call using @ref{with-gerror}). +@end table +@end indentedblock +@end deffn + + @anchor{g-callable-info-is-method} @deffn Procedure g-callable-info-is-method info diff --git a/doc/cr-gobject-type-info.texi b/doc/cr-gobject-type-info.texi index eee9216..f467c78 100644 --- a/doc/cr-gobject-type-info.texi +++ b/doc/cr-gobject-type-info.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2016 - 2022 Free Software Foundation, Inc. +@c Copyright (C) 2016 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -24,6 +24,7 @@ Type Information — The GLib Runtime type identification and management system @item @ref{g-type-class-ref} @item @ref{g-type-class-peek} @item @ref{g-type-class-unref} +@item @ref{g-type-class-peek-parent} @item @ref{g-type-interface-peek} @item @ref{g-type-interfaces} @item @ref{g-type-query} @@ -172,6 +173,17 @@ further dereference a finalized class is invalid. @end deffn +@anchor{g-type-class-peek-parent} +@deffn Procedure g-type-class-peek-parent g-class + +Returns a pointer or @code{#f}. + +Obtains and returns a pointer to the class structure of the immediate +parent type for @var{g-class} (a pointer to a @code{GTypeClass} +structure). If no immediate parent type exists, it returns @code{#f}. +@end deffn + + @anchor{g-type-interface-peek} @deffn Procedure g-type-interface-peek g-class iface-type diff --git a/doc/introduction.texi b/doc/introduction.texi index cdd317f..4565ea6 100644 --- a/doc/introduction.texi +++ b/doc/introduction.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2016 - 2022 Free Software Foundation, Inc. +@c Copyright (C) 2016 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -103,49 +103,64 @@ file you should grab is: @subheading Dependencies +@strong{-- Main Dependencies} + G-Golf needs the following software to run: @itemize @bullet - @item -Autoconf >= 2.69 +Autoconf @geq{} 2.69 @item -Automake >= 1.14 +Automake @geq{} 1.14 @item -Makeinfo >= 6.6 +Makeinfo @geq{} 6.6 @item -@uref{@value{UGUILE}, Guile} >= 2.0.14 +@uref{@value{UGUILE}, Guile} @geq{} 2.0.14 -[allows 2.2 and 3.0 (>= 3.0.7)] +[allows 2.2 and 3.0 (@geq{} 3.0.7)] @item -@uref{@value{UGUILE-LIB}, Guile-Lib} >= 0.2.5 +@uref{@value{UGUILE-LIB}, Guile-Lib} @geq{} 0.2.5 @item -@uref{@value{UGLIB}, Glib-2.0} >= 2.48.0 +@uref{@value{UGLIB}, Glib-2.0} @geq{} 2.48.0 @item -@uref{@value{UGOBJECT}, Gobject-2.0} >= 2.48.0 +@uref{@value{UGOBJECT}, Gobject-2.0} @geq{} 2.48.0 @item -@uref{@value{UGI}, GObject-Introspection-1.0} >= 1.72.0 - +@uref{@value{UGI}, GObject-Introspection-1.0} @geq{} 1.72.0 @end itemize + +@strong{-- Test-Suite Dependencies} + G-Golf currently needs the following additional software to run its test-suite: @itemize @bullet +@item +@uref{@value{UCLUTTER}, Clutter-1.0} @geq{} 1.24.0 @item -@uref{@value{UCLUTTER}, Clutter-1.0} >= 1.24.0 +@uref{@value{UGTK3}, Gtk-3.0} @geq{} 3.10.0 +@end itemize + +@strong{-- Examples Dependencies} + +G-Golf currently needs the following additional software to run its +examples: + +@itemize @bullet @item -@uref{@value{UGTK3}, Gtk-3.0} >= 3.10.0 +@uref{@value{UGTK4}, Gtk-4.0} @geq{} 4.10.0 +@item +@uref{@value{UGUILE-CAIRO}, Guile-Cairo} > 1.11.2 @end itemize diff --git a/doc/ug-ggv-vfunc.texi b/doc/ug-ggv-vfunc.texi index 1f2f3e1..7395bcd 100644 --- a/doc/ug-ggv-vfunc.texi +++ b/doc/ug-ggv-vfunc.texi @@ -55,6 +55,15 @@ context. @end indentedblock +@subheading Special Form + +@indentedblock +@table @code +@item @ref{next-vfunc} +@end table +@end indentedblock + + @subheading Description Welcome to the VFunc G-Golf Alley. @@ -102,9 +111,9 @@ numerous virtual methods: @end lisp The only difference, from a user point of view and as you can see in the -exmple above, is that define-vfunc imposes one (or two, depending on the -context) additional constraint(s) to the VFunc name, fully described in -the @ref{define-vfunc} definition. +example above, is that define-vfunc imposes one (or two, depending on +the context) additional constraint(s) to the VFunc name, fully described +in the @ref{define-vfunc} definition. @c @noindent @@ -280,3 +289,32 @@ Returns the content of their respective slot for @var{inst} (a <vfunc> instance). @end deffn + + +@anchor{next-vfunc} +@subheading Next-vfunc + +In G-Golf, from a user perspective, the next-vfunc concept and mechanism +is to the GObject virtual method system what the next-method concept and +mechanism is to the GOOPS (compute applicable) method system. + +If a vfunc refers to @samp{next-vfunc} in its body, that vfunc will call +the corresponding @samp{immediate parent} virtual function. The exact +@samp{next-vfunc} implementation is only known at runtime, as it is a +function of the vfunc specializer argument. + +G-Golf implements @samp{next-vfunc} by binding it as a closure variable. +An effective virtual method is bound to a specific @samp{next-vfunc} by +the internal @code{%next-vfunc-proc}, which returns the new closure. + +Let's look at an excerpt form the animated-paintable.scm example, which +specializes the GObject finalize virtual method, and as the GNOME team +would say, needs to @samp{chain-up}: + +@lisp +(define-vfunc (finalize-vfunc (self <nuclear-animation>)) + (g-source-remove (!source-id self)) + ;; This vfunc must 'chain-up' - call the <nuclear-animation> parent + ;; finalize virtual method. + (next-vfunc)) +@end lisp diff --git a/doc/ug-gswg-hello-world.texi b/doc/ug-gswg-hello-world.texi index 3d1b539..f69a9fa 100644 --- a/doc/ug-gswg-hello-world.texi +++ b/doc/ug-gswg-hello-world.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2016 - 2021 Free Software Foundation, Inc. +@c Copyright (C) 2016 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -81,7 +81,7 @@ that it is safe to declare it imperceptible. It would be beyond the scope of this introduction to describe the @code{<gtk-application> / g-application-run} instance creation and run mechanism in detail, for this, please consult and carefully read their -respective entries in the @uref{@value{UGTK-APPLICATION}, Gtk} and +respective entries in the @uref{@value{UGTK4-APPLICATION}, Gtk} and @uref{@value{UGIO-G-APPLICATION}, Gio} reference manuals. The GNOME team also maintains a wiki called @uref{@value{UHDI}, HowDoI}, @@ -97,7 +97,7 @@ newcomers: @item as you can see, we do not need to call @code{gtk-init}, it is done -automatically (more on this in the @uref{@value{UGTK-APPLICATION}, +automatically (more on this in the @uref{@value{UGTK4-APPLICATION}, GtkApplication} section of the Gtk Reference Manual);@*@* @item diff --git a/doc/ug-gswg.texi b/doc/ug-gswg.texi index 14f5c53..7950477 100644 --- a/doc/ug-gswg.texi +++ b/doc/ug-gswg.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2016 - 2021 Free Software Foundation, Inc. +@c Copyright (C) 2016 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -13,12 +13,12 @@ GNOME library is called a @uref{@value{UGI-OVERVIEW}, Typelib} - a binary, readonly, memory-mappable database containing reflective information about a GObject library.}. Since we need to make a choice among so many, to guide new comers and get them started with G-Golf, -let's pick-up @uref{@value{UGTK}, Gtk}, and show how to +let's pick-up @uref{@value{UGTK4}, Gtk}, and show how to @uref{@value{UGTK-WEB}, Create interfaces that users just love}. Please note that in the entire course of the G-Golf manual, unless -otherwise specified, examples are based on and use @uref{@value{UGTK}, -Gtk-4.0}, @uref{@value{UGDK}, Gdk-4.0} and @uref{@value{UGSK}, Gsk-4.0} +otherwise specified, examples are based on and use @uref{@value{UGTK4}, +Gtk-4.0}, @uref{@value{UGDK4}, Gdk-4.0} and @uref{@value{UGSK4}, Gsk-4.0} - which is new and only available with Gtk-4.0. G-Golf itself perfectly works and support @uref{@value{UGTK3}, Gtk-3.0} @@ -37,7 +37,7 @@ from GTK 3.x to GTK 4}. the all namespace. * Scripting:: We will continue with a section on @samp{Scripting}, while revisiting our @samp{Hello World!} code, maybe some other example(s) - and exploring a few more @uref{@value{UGTK}, Gtk} widgets. + and exploring a few more @uref{@value{UGTK4}, Gtk} widgets. * Building Applications:: We will proceed with a section describing the necessary and/or recommended steps to build applications, * G-Golf on Mobile Devices:: To conclude, we will look at and show how diff --git a/doc/ug-wwg-events.texi b/doc/ug-wwg-events.texi index 598a6ae..c835552 100644 --- a/doc/ug-wwg-events.texi +++ b/doc/ug-wwg-events.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2021 - 2022 Free Software Foundation, Inc. +@c Copyright (C) 2021 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -22,8 +22,8 @@ Handling events from the window system. Most of the numerous, important and sometimes radical changes in between @uref{@value{UGTK3}, Gtk-3.0}/@uref{@value{UGDK3}, Gdk-3.0} and -@uref{@value{UGTK}, Gtk-4.0}/@uref{@value{UGDK}, -Gdk-4.0}/@uref{@value{UGSK}, Gsk-4.0} have had no impact on G-Golf. And +@uref{@value{UGTK4}, Gtk-4.0}/@uref{@value{UGDK4}, +Gdk-4.0}/@uref{@value{UGSK4}, Gsk-4.0} have had no impact on G-Golf. And by most, we actually mean all but one: the GdkEvent and its API. For this reason, this section is split/organized in two subheading, @@ -388,7 +388,7 @@ list: @sp 1 @ @ @sup{_} @strong{In Gdk-4.0} -In @uref{@value{UGDK}, Gdk-4.0}, GdkEvent is a class@footnote{From a GI +In @uref{@value{UGDK4}, Gdk-4.0}, GdkEvent is a class@footnote{From a GI point of view - internally, it is a C struct.}. GdkEvent structs are opaque and immutable. Direct access to GdkEvent structs is no longer possible in GTK 4. All event fields have accessors. diff --git a/doc/variables.texi b/doc/variables.texi index 85aa505..cc14ac8 100644 --- a/doc/variables.texi +++ b/doc/variables.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU G-Golf Reference Manual. -@c Copyright (C) 2016 - 2022 Free Software Foundation, Inc. +@c Copyright (C) 2016 - 2023 Free Software Foundation, Inc. @c See the file g-golf.texi for copying conditions. @@ -17,6 +17,8 @@ @set UGUILE-LIB http://www.nongnu.org/guile-lib @set USCHEME http://schemers.org +@set UGUILE-CAIRO http://www.nongnu.org/guile-cairo + @set UG-GOLF http://www.gnu.org/software/g-golf/ @set UG-GOLF-learn https://www.gnu.org/software/g-golf/learn.html @set UG-GOLF-RELEASES http://ftp.gnu.org/gnu/g-golf/ @@ -121,12 +123,12 @@ @set UGTK-MIGRATING-3-TO-4 https://developer.gnome.org/gtk4/stable/gtk-migrating-3-to-4.html @set UGTK-WEB https://gtk.org/ -@set UGTK https://developer.gnome.org/gtk4/stable/ -@set UGTK-APPLICATION https://developer.gnome.org/gtk4/stable/GtkApplication.html +@set UGTK4 https://developer.gnome.org/gtk4/stable/ +@set UGTK4-APPLICATION https://developer.gnome.org/gtk4/stable/GtkApplication.html -@set UGDK https://developer.gnome.org/gdk4/stable/ +@set UGDK4 https://developer.gnome.org/gdk4/stable/ -@set UGSK https://developer.gnome.org/gsk4/stable/ +@set UGSK4 https://developer.gnome.org/gsk4/stable/ @c diff --git a/examples/gtk-4/animated-paintable.png b/examples/gtk-4/animated-paintable.png Binary files differnew file mode 100644 index 0000000..24b2372 --- /dev/null +++ b/examples/gtk-4/animated-paintable.png diff --git a/examples/gtk-4/animated-paintable.scm b/examples/gtk-4/animated-paintable.scm new file mode 100755 index 0000000..67cb005 --- /dev/null +++ b/examples/gtk-4/animated-paintable.scm @@ -0,0 +1,148 @@ +#! /bin/sh +# -*- mode: scheme; coding: utf-8 -*- +exec guile -e main -s "$0" "$@" +!# + + +;;;; +;;;; 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: + +;; Note: this example requires guile-cairo, a patched verison of +;; guile-cairo: + +;; https://www.nongnu.org/guile-cairo/ + +;; It actually needs a patched version of guile-cairo, that contains the +;; following new interface (which is not in guile-cairo 1.11.2): + +;; cairo-pointer->context + +;; If by the time you have access to and wish to try this example +;; guile-cairo hasn't been released and/or cairo-pointer->context still +;; isn't commited to the latest guile-cairo repository master branch, +;; get in touch with us on irc.libera.chat, channel #guile, or by email, +;; we'll guide you to manually patch your local version. + +;;; Code: + + +(eval-when (expand load eval) + (use-modules (oop goops)) + + (default-duplicate-binding-handler + '(merge-generics replace warn-override-core warn last)) + + (use-modules (g-golf)) + + (g-irepository-require "Gtk" #:version "4.0") + (for-each (lambda (name) + (gi-import-by-name "Gdk" name)) + '("Paintable")) + + (for-each (lambda (name) + (gi-import-by-name "Gtk" name)) + '("Application" + "ApplicationWindow" + "Image"))) + +(add-to-load-path (dirname (current-filename))) +(use-modules (nuclear-icon)) + + +(define %max-progress 500) +(define %pi (acos -1)) + + +(define-class <nuclear-animation> (<gobject> <gdk-paintable>) + (draw-background #:accessor !draw-background + #:init-keyword #:draw-background) + ;; This slot stores the progress of the animation. We just count + ;; upwards until we hit %max-progress and then start from scratch. + (progress #:accessor !progress #:init-value 0) + ;; This slot holds the ID of the timer that updates our progress slot + ;; value. We need to keep track of it so that we can remove it. + (source-id #:accessor !source-id)) + +(define-method (initialize (self <nuclear-animation>) initargs) + (next-method) + (set! (!source-id self) + (g-timeout-add 10 + (lambda () + (set! (!progress self) + (modulo (+ (!progress self) 1) %max-progress)) + (invalidate-contents self) + #t)))) + +(define-vfunc (snapshot-vfunc (self <nuclear-animation>) snapshot width height) + ;; We call the procedure provided by the (nuclear-icon) module. + (nuclear-snapshot snapshot + (if (!draw-background self) + '(0.9 0.75 0.15 1.0) ;; nuclear yellow + '(0 0 0 0)) ;; transparent + '(0.0 0.0 0.0 1.0) ;; black + width + height + (* 2 %pi (/ (!progress self) %max-progress)))) + +(define-vfunc (get-current-image-vfunc (self <nuclear-animation>)) + ;; For non-static paintables, this virtual function needs to be + ;; implemented. It must return a static paintable with the same + ;; contents as the one currently has. + + ;; This is why the rotation slot was added to the <nuclear-icon> + ;; class, so we can just return a new <nuclear-icon> instance. + (make <nuclear-icon> + #:rotaton (* 2 %pi (/ (!progress self) %max-progress)))) + +(define-vfunc (get-flags-vfunc (self <nuclear-animation>)) + ;; This time, we cannot set the static contents flag because the + ;; animation changes the contents. However, the size still doesn't + ;; change, so report that flag. + '(size)) + +(define-vfunc (finalize-vfunc (self <nuclear-animation>)) + (g-source-remove (!source-id self)) + ;; This vfunc must 'chain-up' - call the <nuclear-animation> parent + ;; finalize virtual method. + (next-vfunc)) + + +(define (activate app) + (let ((window (make <gtk-application-window> + #:title "Nuclear Animation" + #:default-width 300 + #:default-height 200 + #:application app)) + (nuclear (make <nuclear-animation> #:draw-background #t)) + (image (make <gtk-image>))) + (set-from-paintable image nuclear) + (set-child window image) + (show window))) + + +(define (main args) + (let ((app (make <gtk-application> + #:application-id "org.gtk.example"))) + (connect app 'activate activate) + (let ((status (g-application-run app args))) + (exit status)))) diff --git a/examples/gtk-4/nuclear-icon.scm b/examples/gtk-4/nuclear-icon.scm new file mode 100755 index 0000000..23d9a02 --- /dev/null +++ b/examples/gtk-4/nuclear-icon.scm @@ -0,0 +1,117 @@ +;; -*- 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: + +;; Note: this example requires guile-cairo, a patched verison of +;; guile-cairo: + +;; https://www.nongnu.org/guile-cairo/ + +;; It actually needs a patched version of guile-cairo, that contains the +;; following new interface (which is not in guile-cairo 1.11.2): + +;; cairo-pointer->context + +;; If by the time you have access to and wish to try this example +;; guile-cairo hasn't been released and/or cairo-pointer->context still +;; isn't commited to the latest guile-cairo repository master branch, +;; get in touch with us on irc.libera.chat, channel #guile, or by email, +;; we'll guide you to manually patch your local version. + +;;; Code: + + +(define-module (nuclear-icon) + #:use-module (oop goops) + #:use-module (g-golf) + #:use-module (cairo) + + #:duplicates (merge-generics + replace + warn-override-core + warn + last) + + #:export (<nuclear-icon> + nuclear-snapshot)) + + +#;(g-export ) + + +(eval-when (expand load eval) + (g-irepository-require "Gtk" #:version "4.0") + (for-each (lambda (name) + (gi-import-by-name "Gdk" name)) + '("Paintable")) + + (for-each (lambda (name) + (gi-import-by-name "Gtk" name)) + '("Snapshot"))) + + + +(define-class <nuclear-icon> (<gobject> <gdk-paintable>) + (rotation #:accessor !rotation #:init-keyword #:rotation)) + +(define-vfunc (get-flags-vfunc (self <nuclear-icon>)) + '(size contents)) + +(define-vfunc (snapshot-vfunc (self <nuclear-icon>) snapshot width height) + (nuclear-snapshot snapshot + '(0.9 0.75 0.15 1.0) ;; nuclear yellow + '(0.0 0.0 0.0 1.0) ;; black + width + height + (!rotation self))) + +(define (nuclear-snapshot snapshot background foreground width height rotation) + (append-color snapshot + background + (graphene-rect-init (graphene-rect-alloc) 0 0 width height)) + (let* ((size (min width height)) + (ctx (append-cairo snapshot + (graphene-rect-init (graphene-rect-alloc) + (/ (- width size) 2) + (/ (- height size) 2) + size + size))) + (cr (cairo-pointer->context ctx)) + (radius 0.3) + (pi (acos -1))) + (match foreground + ((r g b a) + (cairo-set-source-rgba cr r g b a))) + (cairo-translate cr (/ width 2.0) (/ height 2.0)) + (cairo-scale cr size size) + (cairo-rotate cr rotation) + + (cairo-arc cr 0 0 0.1 (- pi) pi) + (cairo-fill cr) + + (cairo-set-line-width cr radius) + (cairo-set-dash cr `#(,(/ (* radius pi) 3)) 0.0) + (cairo-arc cr 0 0 radius (- pi) pi) + (cairo-stroke cr) + (cairo-destroy cr))) diff --git a/examples/gtk-4/simple-paintable.png b/examples/gtk-4/simple-paintable.png Binary files differnew file mode 100644 index 0000000..13d553c --- /dev/null +++ b/examples/gtk-4/simple-paintable.png diff --git a/examples/gtk-4/simple-paintable.scm b/examples/gtk-4/simple-paintable.scm new file mode 100755 index 0000000..314b61b --- /dev/null +++ b/examples/gtk-4/simple-paintable.scm @@ -0,0 +1,90 @@ +#! /bin/sh +# -*- mode: scheme; coding: utf-8 -*- +exec guile -e main -s "$0" "$@" +!# + + +;;;; +;;;; 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: + +;; Note: this example requires guile-cairo, a patched verison of +;; guile-cairo: + +;; https://www.nongnu.org/guile-cairo/ + +;; It actually needs a patched version of guile-cairo, that contains the +;; following new interface (which is not in guile-cairo 1.11.2): + +;; cairo-pointer->context + +;; If by the time you have access to and wish to try this example +;; guile-cairo hasn't been released and/or cairo-pointer->context still +;; isn't commited to the latest guile-cairo repository master branch, +;; get in touch with us on irc.libera.chat, channel #guile, or by email, +;; we'll guide you to manually patch your local version. + +;;; Code: + + +(eval-when (expand load eval) + (use-modules (oop goops)) + + (default-duplicate-binding-handler + '(merge-generics replace warn-override-core warn last)) + + (use-modules (g-golf)) + + (g-irepository-require "Gtk" #:version "4.0") + (for-each (lambda (name) + (gi-import-by-name "Gdk" name)) + '("Paintable")) + + (for-each (lambda (name) + (gi-import-by-name "Gtk" name)) + '("Application" + "ApplicationWindow" + "Image"))) + +(add-to-load-path (dirname (current-filename))) +(use-modules (nuclear-icon)) + + +(define (activate app) + (let ((window (make <gtk-application-window> + #:title "Nuclear Icon" + #:default-width 300 + #:default-height 200 + #:application app)) + (nuclear (make <nuclear-icon> #:rotation 0.0)) + (image (make <gtk-image>))) + (set-from-paintable image nuclear) + (set-child window image) + (show window))) + + +(define (main args) + (let ((app (make <gtk-application> + #:application-id "org.gtk.example"))) + (connect app 'activate activate) + (let ((status (g-application-run app args))) + (exit status)))) @@ -1,7 +1,7 @@ ;; -*- mode: scheme; coding: utf-8 -*- ;;;; -;;;; Copyright (C) 2016 - 2022 +;;;; Copyright (C) 2016 - 2023 ;;;; Free Software Foundation, Inc. ;;;; This file is part of GNU G-Golf @@ -260,8 +260,12 @@ (gi-import-by-name "GObject" "BindingFlags" #:force? #t) (gi-import-by-name "GObject" "TypeFlags" #:force? #t) - (let ((%gi-import-object-methods - (@@ (g-golf hl-api object) gi-import-object-methods)) - (g-object-info - (g-irepository-find-by-name "GObject" "Object"))) + (let* ((%gi-import-object-methods + (@@ (g-golf hl-api object) gi-import-object-methods)) + (g-object-info + (g-irepository-find-by-name "GObject" "Object")) + (class-struct (g-object-info-get-class-struct g-object-info))) + (mslot-set! <gobject> + 'info g-object-info + 'g-struct-fields (gi-struct-field-desc class-struct)) (%gi-import-object-methods g-object-info #:force? #t))) diff --git a/g-golf/gi/callable-info.scm b/g-golf/gi/callable-info.scm index 9a7efb2..5807bf4 100644 --- a/g-golf/gi/callable-info.scm +++ b/g-golf/gi/callable-info.scm @@ -1,7 +1,7 @@ ;; -*- mode: scheme; coding: utf-8 -*- ;;;; -;;;; Copyright (C) 2016 - 2022 +;;;; Copyright (C) 2016 - 2023 ;;;; Free Software Foundation, Inc. ;;;; This file is part of GNU G-Golf @@ -39,11 +39,13 @@ #:export (gi-callable-show + g-callable-info-can-throw-gerror g-callable-info-get-n-args g-callable-info-get-arg g-callable-info-get-caller-owns g-callable-info-get-instance-ownership-transfer g-callable-info-get-return-type + g-callable-info-invoke g-callable-info-is-method g-callable-info-may-return-null g-callable-info-create-closure)) @@ -60,6 +62,7 @@ namespace: ~S name: ~S type: ~S + can-throw-gerror: ~S n-arg: ~A caller-owns: ~S iot: ~S [ instance-ownership-transfer @@ -79,6 +82,7 @@ (g-base-info-get-namespace info) (g-base-info-get-name info) (g-base-info-get-type info) + (g-callable-info-can-throw-gerror info) (g-callable-info-get-n-args info) (g-callable-info-get-caller-owns info) (g-callable-info-get-instance-ownership-transfer info) @@ -91,6 +95,9 @@ ;;; Low level API ;;; +(define (g-callable-info-can-throw-gerror info) + (gi->scm (g_callable_info_can_throw_gerror info) 'boolean)) + (define (g-callable-info-get-n-args info) (g_callable_info_get_n_args info)) @@ -108,6 +115,23 @@ (define (g-callable-info-get-return-type info) (gi->scm (g_callable_info_get_return_type info) 'pointer)) +(define (g-callable-info-invoke info + f-ptr + in-args n-in + out-args n-out + r-val + is-method + throws + g-error) + (g_callable_info_invoke info + f-ptr + in-args n-in + out-args n-out + r-val + (scm->gi is-method 'boolean) + (scm->gi throws 'boolean) + g-error)) + (define (g-callable-info-is-method info) (gi->scm (g_callable_info_is_method info) 'boolean)) @@ -145,6 +169,12 @@ ;;; GI Bindings ;;; +(define g_callable_info_can_throw_gerror + (pointer->procedure int + (dynamic-func "g_callable_info_can_throw_gerror" + %libgirepository) + (list '*))) + (define g_callable_info_get_n_args (pointer->procedure int (dynamic-func "g_callable_info_get_n_args" @@ -175,6 +205,21 @@ %libgirepository) (list '*))) +(define g_callable_info_invoke + (pointer->procedure int + (dynamic-func "g_callable_info_invoke" + %libgirepository) + (list '* ;; info + '* ;; function + '* ;; in-args + int ;; n-in + '* ;; out-args + int ;; n-out + '* ;; r-val + int ;; is-method + int ;; throws + '*))) ;; g-error + (define g_callable_info_is_method (pointer->procedure int (dynamic-func "g_callable_info_is_method" diff --git a/g-golf/gi/common-types.scm b/g-golf/gi/common-types.scm index 4d42d42..58385aa 100644 --- a/g-golf/gi/common-types.scm +++ b/g-golf/gi/common-types.scm @@ -58,7 +58,8 @@ gi-argument-ref gi-argument-set! gi-type-tag->field - gi-type-tag->bv-acc)) + gi-type-tag->bv-acc + gi-type-tag->ffi-type)) ;;; @@ -243,6 +244,36 @@ add as a comment)." (else (error "No such GI type tag: " type-tag)))) +(define (gi-type-tag->ffi-type type-tag is-pointer? is-enum?) + (case type-tag + ((boolean) int) + ((int8 + uint8 + int16 + uint16 + int32 + uint32 + int64 + uint64 + float + double) (primitive-eval type-tag)) + ((gtype) unsigned-long) + ((utf8 + filename + array + glist + gslist + ghash + error) '*) + ((interface) + (if is-enum? int32 '*)) + ((void) + (if is-pointer? '* void)) + (else + (scm-error 'failed #f + "Unimplemented gi-type-tag->ffi-type type-tag: ~A" + (list type-tag) #f)))) + ;;; ;;; GI Bindings diff --git a/g-golf/gi/function-info.scm b/g-golf/gi/function-info.scm index ed23b0d..3e3f1b3 100644 --- a/g-golf/gi/function-info.scm +++ b/g-golf/gi/function-info.scm @@ -171,11 +171,11 @@ #f))) (define (g-function-info-invoke info - in-args n-int + in-args n-in out-args n-out r-val g-error) - (g_function_info_invoke info in-args n-int out-args n-out r-val g-error)) + (g_function_info_invoke info in-args n-in out-args n-out r-val g-error)) ;;; diff --git a/g-golf/gobject/type-info.scm b/g-golf/gobject/type-info.scm index 605d0b2..c579d4a 100644 --- a/g-golf/gobject/type-info.scm +++ b/g-golf/gobject/type-info.scm @@ -1,7 +1,7 @@ ;; -*- mode: scheme; coding: utf-8 -*- ;;;; -;;;; Copyright (C) 2016 - 2022 +;;;; Copyright (C) 2016 - 2023 ;;;; Free Software Foundation, Inc. ;;;; This file is part of GNU G-Golf @@ -57,6 +57,7 @@ g-type-class-ref g-type-class-peek g-type-class-unref + g-type-class-peek-parent g-type-interface-peek g-type-interfaces g-type-query @@ -127,6 +128,9 @@ (define (g-type-class-unref g-class) (g_type_class_unref g-class)) +(define (g-type-class-peek-parent g-class) + (gi->scm (g_type_class_peek_parent g-class) 'pointer)) + (define (g-type-interface-peek g-class iface-type) (gi->scm (g_type_interface_peek g-class iface-type) 'pointer)) @@ -286,6 +290,12 @@ %libgobject) (list '*))) +(define g_type_class_peek_parent + (pointer->procedure '* + (dynamic-func "g_type_class_peek_parent" + %libgobject) + (list '*))) + (define g_type_interface_peek (pointer->procedure '* (dynamic-func "g_type_interface_peek" diff --git a/g-golf/hl-api/callable.scm b/g-golf/hl-api/callable.scm index d004877..3f4887d 100644 --- a/g-golf/hl-api/callable.scm +++ b/g-golf/hl-api/callable.scm @@ -77,6 +77,7 @@ 'g-name g-name 'name name)) (mslot-set! self + 'can-throw-gerror (g-callable-info-can-throw-gerror info) 'is-method? (g-callable-info-is-method info) 'caller-owns (g-callable-info-get-caller-owns info) 'return-type return-type @@ -721,12 +722,12 @@ callable ;; the type-desc instance 'owner' #:args-out args-out))) -(define* (gi-argument->scm type-tag type-desc gi-argument funarg +(define* (gi-argument->scm type-tag type-desc gi-argument clb/arg #:key (forced-type #f) (is-pointer? #f) (args-out #f)) ;; forced-type is only used for 'inout and 'out arguments, in which ;; case it is 'pointer - see 'simple' types below. - ;; funarg is the instance that owns the type-desc, which might need to + ;; clb/arg is the instance that owns the type-desc, which might need to ;; be updated - see the comment in the 'interface/'object section of ;; the code below, as well as the comment in registered-type->gi-type ;; which explains why/when this might happen. @@ -765,8 +766,8 @@ (else (if (or (!is-opaque? gi-type) (!is-semi-opaque? gi-type)) - (let ((bv (slot-ref funarg 'bv-cache)) - (bv-ptr (slot-ref funarg 'bv-cache-ptr))) + (let ((bv (slot-ref clb/arg 'bv-cache)) + (bv-ptr (slot-ref clb/arg 'bv-cache-ptr))) (if bv (begin (g-boxed-sa-guard bv-ptr bv) @@ -803,7 +804,7 @@ (not (null-pointer? foreign)) (receive (class name g-type) (g-object-find-class foreign) - ;; We used to update the funarg 'type-desc + ;; We used to update the clb/arg 'type-desc ;; argument when it wasn't confirmed?, but that ;; actually won't work anymore, see the comment ;; labeled [1] in (g-golf hl-api gobject) for a @@ -811,7 +812,7 @@ ;; code, commented, for now, until I clear all ;; occurrences of the confirmed? pattern entries. #;(unless confirmed? - (set! (!type-desc funarg) + (set! (!type-desc clb/arg) (list 'object name class g-type #t))) (make class #:g-inst foreign))))))))))) ((array) diff --git a/g-golf/hl-api/callback.scm b/g-golf/hl-api/callback.scm index 214017a..273ecb1 100644 --- a/g-golf/hl-api/callback.scm +++ b/g-golf/hl-api/callback.scm @@ -217,7 +217,7 @@ float double gtype - utf + utf8 filename) ffi-value) ((array diff --git a/g-golf/hl-api/ccc.scm b/g-golf/hl-api/ccc.scm index 18b1e62..26ad431 100644 --- a/g-golf/hl-api/ccc.scm +++ b/g-golf/hl-api/ccc.scm @@ -55,6 +55,7 @@ !g-name !name !override? + !can-throw-gerror !is-method? !n-arg !al-pos @@ -94,6 +95,7 @@ (g-name #:accessor !g-name #:init-keyword #:g-name) (name #:accessor !name #:init-keyword #:name) (override? #:accessor !override? #:init-keyword #:override? #:init-value #f) + (can-throw-gerror #:accessor !can-throw-gerror #:init-keyword #:can-throw-gerror) (is-method? #:accessor !is-method?) (n-arg #:accessor !n-arg) (al-pos #:accessor !al-pos) diff --git a/g-golf/hl-api/n-decl.scm b/g-golf/hl-api/n-decl.scm index 32c9376..718136f 100644 --- a/g-golf/hl-api/n-decl.scm +++ b/g-golf/hl-api/n-decl.scm @@ -1,7 +1,7 @@ ;; -*- mode: scheme; coding: utf-8 -*- ;;;; -;;;; Copyright (C) 2022 +;;;; Copyright (C) 2022 - 2023 ;;;; Free Software Foundation, Inc. ;;;; This file is part of GNU G-Golf @@ -96,10 +96,13 @@ (define g-name-transform-exception-remove #f) (define g-name-transform-exception-reset #f) -(let ((%g-name-transform-exception +(let* ((%g-name-transform-exception-default '(("GObject" . "gobject") + ("GInterface" . "ginterface") ("GIVFuncInfo" . "gi-vfunc-info") - ("GIVFuncInfoFlags" . "gi-vfunc-info-flags")))) + ("GIVFuncInfoFlags" . "gi-vfunc-info-flags"))) + (%g-name-transform-exception + %g-name-transform-exception-default)) (set! g-name-transform-exception (lambda () @@ -116,14 +119,14 @@ (set! g-name-transform-exception-remove (lambda (key) - (unless (string=? key "GObject") + (unless (assoc-ref %g-name-transform-exception-default key) (set! %g-name-transform-exception (assoc-remove! %g-name-transform-exception key))))) (set! g-name-transform-exception-reset (lambda () (set! %g-name-transform-exception - '(("GObject" . "gobject")))))) + %g-name-transform-exception-default)))) ;;; diff --git a/g-golf/hl-api/vfunc.scm b/g-golf/hl-api/vfunc.scm index 1304cdd..7a499e5 100644 --- a/g-golf/hl-api/vfunc.scm +++ b/g-golf/hl-api/vfunc.scm @@ -1,7 +1,7 @@ ;; -*- mode: scheme; coding: utf-8 -*- ;;;; -;;;; Copyright (C) 2022 +;;;; Copyright (C) 2022 - 2023 ;;;; Free Software Foundation, Inc. ;;;; This file is part of GNU G-Golf @@ -35,6 +35,7 @@ #:use-module (g-golf glib) #:use-module (g-golf gobject) #:use-module (g-golf gi) + #:use-module (g-golf hl-api n-decl) #:use-module (g-golf hl-api gtype) #:use-module (g-golf hl-api gobject) #:use-module (g-golf hl-api argument) @@ -83,67 +84,70 @@ (format #f "~S" (slot-ref self name)) "#<unbound>")))) (class-direct-slots (class-of self))) + #;(format #t " Method slots are: ~%") + #;(for-each (lambda (slot) + (let ((name (slot-definition-name slot))) + (format #t " ~S = ~A~%" + name + (if (slot-bound? self name) + (format #f "~S" (slot-ref self name)) + "#<unbound>")))) + (class-direct-slots <method>)) *unspecified*) (define-syntax define-vfunc (syntax-rules () - ((_ (gf-name . args) body ...) - (let ((inst (vfunc args body ...))) + ((_ (vf-name . args) body ...) + (let ((vf (vfunc 'vf-name args body ...))) (receive (specializer g-name g-long-name-prefix gf-long-name? info) - (vfunc-checks 'gf-name inst) - (mslot-set! inst + (vfunc-checks 'vf-name (slot-ref vf 'specializers)) + (mslot-set! vf 'specializer specializer 'name (g-name->name g-name) 'g-name (string->symbol g-name) 'long-name-prefix (g-name->name g-long-name-prefix) 'gf-long-name? gf-long-name? 'info info) - (add-method! (gi-add-method-gf 'gf-name) inst) - (add-vfunc-closure inst)))))) + (add-method! (gi-add-method-gf 'vf-name) vf) + (add-vfunc-closure vf)))))) -(define (add-vfunc-closure inst) +(define (add-vfunc-closure vf) (receive (closure callback-closure) - (g-golf-vfunc-closure inst) + (g-golf-vfunc-closure vf) (let* ((vfunc-g-object-class-specializer - (find-vfunc-g-object-class-specializer inst)) - (specializer (!specializer inst)) + (find-vfunc-g-object-class-specializer vf)) + (specializer (!specializer vf)) (iface/class-struct (if (ginterface-class? specializer) (g-type-interface-peek (!g-class vfunc-g-object-class-specializer) (!g-type specializer)) (g-type-class-peek (!g-type vfunc-g-object-class-specializer))))) - (slot-set! inst + (slot-set! vf 'callback (!callback callback-closure)) - (match (vfunc-struct-field inst) + (match (vfunc-struct-field vf) ((type-tag offset flags) (bv-ptr-set! (gi-pointer-inc iface/class-struct offset) closure)))))) -(define (find-vfunc-g-object-class-specializer inst) +(define (find-vfunc-g-object-class-specializer vf) ;; There can only be one GObject class - as GObject is a single - ;; inheritance oop system - in the list of the <vfunc> inst + ;; inheritance oop system - in the list of the <vfunc> vf ;; specializers. - (let loop ((specializers (slot-ref inst 'specializers))) - (match specializers - (() - (scm-error 'impossible #f "No GObject specializer for: ~S" - (list (!name inst)) #f)) - ((specializer . rests) - (or (and (gobject-class? specializer) - specializer) - (loop rests)))))) - -(define (vfunc-struct-field inst) - (assq-ref (!g-struct-fields (!specializer inst)) - (!name inst))) - -(define (g-golf-vfunc-closure inst) - (let* ((name (symbol-append (!long-name-prefix inst) + (or (find gobject-class? (slot-ref vf 'specializers)) + (scm-error 'impossible #f "No GObject specializer for: ~S" + (list (!name vf)) #f))) + +(define (vfunc-struct-field vf) + (assq-ref (!g-struct-fields (!specializer vf)) + (!name vf))) + +(define (g-golf-vfunc-closure vf) + (let* ((name (symbol-append (!long-name-prefix vf) '- - (!name inst))) - (info (!info inst)) - (proc (slot-ref inst 'procedure)) + (!name vf))) + (info (!info vf)) + (proc (slot-ref vf 'procedure)) (callback (gi-import-vfunc name info)) (callback-closure (make <callback-closure> #:callback callback @@ -175,13 +179,13 @@ "More then one specializer defines a VFunc (method) for NAME: ~S. In these situations a VFunc (method) long name is mandatory and ~S is invalid.") -(define (vfunc-checks gf-name inst) - (let ((str-name (symbol->string gf-name))) +(define (vfunc-checks vf-name specializers) + (let ((str-name (symbol->string vf-name))) (case (string-suffix-length str-name "-vfunc") ((6) (let* ((name (string-drop-right str-name 6)) (g-name (name->g-name name 'as-string)) - (results (specializers-vfunc-lookup inst g-name))) + (results (specializers-vfunc-lookup specializers g-name))) (match results (() (scm-error 'wrong-type-arg #f "No such VFunc : ~S" @@ -196,15 +200,15 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") ;; Then there is more then one specializer that defines a VFunc ;; for G-NAME. In this case, we filter the results to keep, if ;; any, the only one result that would have its gf-long-name? - ;; #t. Otherwise, it means that GF-NAME is a VFunc short name, - ;; which in this situation is invalid, or GF-NAME is an invalid + ;; #t. Otherwise, it means that VF-NAME is a VFunc short name, + ;; which in this situation is invalid, or VF-NAME is an invalid ;; long name (as a typo in the long name prefix) an exception is ;; raised. (let ((the-result (vfunc-checks-filter results))) (match the-result (#f (scm-error 'wrong-type-arg #f %mandatory-long-name-error-msg - (list results gf-name) #f)) + (list results vf-name) #f)) ((specializer g-name g-long-name-prefix gf-long-name? info) (values specializer g-name @@ -213,7 +217,7 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") info)))))))) (else (scm-error 'wrong-type-arg #f "Invalid vfunc name: ~S" - (list gf-name) #f))))) + (list vf-name) #f))))) (define (vfunc-checks-filter results) (let loop ((results results)) @@ -226,8 +230,8 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") result (loop rest)))))))) -(define (specializers-vfunc-lookup inst g-name) - (let loop ((specializers (slot-ref inst 'specializers)) +(define (specializers-vfunc-lookup specializers g-name) + (let loop ((specializers specializers) (results '())) (match specializers (() results) @@ -276,14 +280,97 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") (g-interface-info-find-vfunc (!info c-lass) g-name)) -;; Below is a copy of the (define-syntax method ...) code in (oop goops) - a -;; copy just slightly altered, changing <method> occurrences to <vfunc>. I -;; actualy had to do this, rather then merely call (make <vfunc ...), because -;; this syntax is full of internal defs that one also needs when subclassing -;; <method>. +;; Below is a modified version of the (define-syntax method ...) code in +;; (oop goops) - from which the vfunc syntax-case below is largely +;; inspired. + +(define %next-vfunc + (lambda args + #;(dimfi 'next-vfunc args) + (match args + ((vf-name . rest) + (receive (vf specializer s-class) + (find-vf vf-name rest) + (let* ((name (!name vf)) + (p-class (find gobject-class? + (class-direct-supers s-class))) + (g-struct-fields (!g-struct-fields p-class))) + (match (assq-ref g-struct-fields name) + ((type-tag offset flags) + (let* ((g-class (!g-class p-class)) + (bv-ptr (gi-pointer-inc g-class offset)) + (vfunc-ptr (bv-ptr-ref bv-ptr)) + (procedure (%next-vfunc-proc (!callback vf) vfunc-ptr))) + (apply procedure rest)))))))))) + +(define (find-vf vf-name args) + (letrec* ((module (resolve-module '(g-golf hl-api gobject))) + (gf (module-ref module vf-name)) + (specializer (find (lambda (arg) + (and (gobject-class? (class-of arg)) + arg)) + args)) + (s-class (class-of specializer)) + (vf-pred (lambda (vf) + (memq s-class (slot-ref vf 'specializers))))) + (values (find vf-pred (generic-function-methods gf)) + specializer + s-class))) + +(define (%next-vfunc-proc callback function) + (lambda args + (let ((callback callback) + (info (!info callback)) + (name (!name callback)) + (return-type (!return-type callback)) + (n-gi-arg-in (!n-gi-arg-in callback)) + (gi-args-in (!gi-args-in callback)) + (n-gi-arg-out (!n-gi-arg-out callback)) + (gi-args-out (!gi-args-out callback)) + (gi-arg-result (!gi-arg-result callback))) + #;(dimfi '%next-vfunc-proc) + #;(dimfi " " return-type n-gi-arg-in n-gi-arg-out) + (callable-prepare-gi-arguments callback args) + (with-gerror g-error + (g-callable-info-invoke info + function + gi-args-in + n-gi-arg-in + gi-args-out + n-gi-arg-out + gi-arg-result + (!is-method? callback) + (!can-throw-gerror callback) + g-error)) + #;(dimfi " " 'after-g-callable-info-invoke) + (if (> n-gi-arg-out 0) + (case return-type + ((boolean) + (if (gi-strip-boolean-result? name) + (if (callable-return-value->scm callback) + (apply values + (map callable-arg-out->scm (!args-out callback))) + (error " " name " failed.")) + (apply values + (cons (callable-return-value->scm callback) + (map callable-arg-out->scm (!args-out callback)))))) + ((void) + (apply values + (map callable-arg-out->scm (!args-out callback)))) + (else + (let ((args-out (map callable-arg-out->scm (!args-out callback)))) + (apply values + (cons (callable-return-value->scm callback #:args-out args-out) + args-out))))) + (case return-type + ((void) (values)) + (else + (callable-return-value->scm callback))))))) + (define-syntax vfunc (lambda (x) + (define (parse-args args) (let lp ((ls args) (formals '()) (specializers '())) (syntax-case ls () @@ -329,7 +416,7 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") (() (reverse out)) (tail (reverse (cons #'tail out)))))) - (define (compute-make-procedure formals body next-method) + #;(define (compute-make-procedure formals body next-method) (syntax-case body () ((body ...) (with-syntax ((next-method next-method)) @@ -338,6 +425,7 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") #'(lambda (real-next-method) (lambda (formal ...) (let ((next-method (lambda args + (dimfi 'next-method args) (if (null? args) (real-next-method formal ...) (apply real-next-method args))))) @@ -347,12 +435,13 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") #'(lambda (real-next-method) (lambda formals (let ((next-method (lambda args + (dimfi 'next-method args) (if (null? args) (apply real-next-method formal ...) (apply real-next-method args))))) body ...)))))))))) - (define (compute-procedures formals body) + #;(define (compute-procedures formals body) ;; So, our use of this is broken, because it operates on the ;; pre-expansion source code. It's equivalent to just searching ;; for referent in the datums. Ah well. @@ -364,19 +453,49 @@ situations a VFunc (method) long name is mandatory and ~S is invalid.") (values (compute-procedure formals body) #'#f)))) + (define (compute-procedure-with-next-vfunc vf-name formals body next-vfunc) + (syntax-case body () + ((body0 ...) + (with-syntax ((vf-name vf-name) + (next-vfunc next-vfunc)) + (syntax-case formals () + ((formal ...) + #'(lambda (formal ...) + (let ((next-vfunc (lambda args + (if (null? args) + (%next-vfunc vf-name formal ...) + (apply %next-vfunc (cons vf-name args)))))) + body0 ...))) + (formals + (with-syntax (((formal ...) (->proper #'formals))) + #'(lambda formals + (let ((next-vfunc (lambda args + (if (null? args) + (apply %next-vfunc vf-name formal ...) + (apply %next-vfunc (cons vf-name args)))))) + body0 ...))))))))) + + (define (compute-procedures vf-name formals body) + ;; In this version, we always return #f as the second value, which + ;; is the make-procedure in the next-method version. + (let ((id (find-free-id body 'next-vfunc))) + (if id + (values (compute-procedure-with-next-vfunc vf-name formals body id) + #'#f) + (values (compute-procedure formals body) + #'#f)))) + (syntax-case x () - ((_ args) #'(vfunc args (if #f #f))) - ((_ args body0 body1 ...) + ((_ vf-name args) #'(vfunc vf-name args (if #f #f))) + ((_ vf-name args body0 body1 ...) (with-syntax (((formals (specializer ...)) (parse-args #'args))) - (call-with-values - (lambda () - (compute-procedures #'formals #'(body0 body1 ...))) - (lambda (procedure make-procedure) - (with-syntax ((procedure procedure) - (make-procedure make-procedure)) - #'(make <vfunc> - #:specializers (cons* specializer ...) - #:formals 'formals - #:body '(body0 body1 ...) - #:make-procedure make-procedure - #:procedure procedure))))))))) + (receive (procedure make-procedure) + (compute-procedures #'vf-name #'formals #'(body0 body1 ...)) + (with-syntax ((procedure procedure) + (make-procedure make-procedure)) + #'(make <vfunc> + #:specializers (cons* specializer ...) + #:formals 'formals + #:body '(body0 body1 ...) + #:make-procedure make-procedure + #:procedure procedure)))))))) |
