gauche-gtk-0.6+git20160927/000077500000000000000000000000001300401456300150045ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/.gitignore000066400000000000000000000205351300401456300170010ustar00rootroot00000000000000autom4te.cache/ config.log config.status configure Gauche-gtk2.gpd Makefile VERSION *.o *.so glgd/Makefile gtkgl/Makefile lib/Makefile lib/gtk/gdkkeysyms.scm src/Makefile src/gauche-gdklib.c src/gauche-glib.c src/gdk-pixbuf-core.c src/gdk-pixbuf-core.stub src/gdk-pixbuf-features.c src/gdk-pixbuf-features.stub src/gdk-pixbuf-loader.c src/gdk-pixbuf-loader.stub src/gdk-pixbuf-transform.c src/gdk-pixbuf-transform.stub src/gdk-pixbuf.c src/gdk-pixbuf.stub src/gdk-pixdata.c src/gdk-pixdata.stub src/gdk.c src/gdk.stub src/gdkcolor.c src/gdkcolor.stub src/gdkcursor.c src/gdkcursor.stub src/gdkdisplay.c src/gdkdisplay.stub src/gdkdnd.c src/gdkdnd.stub src/gdkdrawable.c src/gdkdrawable.stub src/gdkenumtypes.c src/gdkenumtypes.stub src/gdkevents.c src/gdkevents.stub src/gdkfont.c src/gdkfont.stub src/gdkgc.c src/gdkgc.stub src/gdkimage.c src/gdkimage.stub src/gdkinput.c src/gdkinput.stub src/gdkkeys.c src/gdkkeys.stub src/gdkpango.c src/gdkpango.stub src/gdkpixbuf.c src/gdkpixbuf.stub src/gdkpixmap.c src/gdkpixmap.stub src/gdkproperty.c src/gdkproperty.stub src/gdkregion.c src/gdkregion.stub src/gdkrgb.c src/gdkrgb.stub src/gdkscreen.c src/gdkscreen.stub src/gdkselection.c src/gdkselection.stub src/gdktypes.c src/gdktypes.stub src/gdkvisual.c src/gdkvisual.stub src/gdkwindow.c src/gdkwindow.stub src/gtk-config.h src/gtk-lib.h src/gtk-lib.inits src/gtk-lib.types src/gtk_head.c src/gtk_tail.c src/gtkaboutdialog.c src/gtkaboutdialog.stub src/gtkaccelgroup.c src/gtkaccelgroup.stub src/gtkaccellabel.c src/gtkaccellabel.stub src/gtkaccelmap.c src/gtkaccelmap.stub src/gtkaccessible.c src/gtkaccessible.stub src/gtkaction.c src/gtkaction.stub src/gtkactiongroup.c src/gtkactiongroup.stub src/gtkadjustment.c src/gtkadjustment.stub src/gtkalignment.c src/gtkalignment.stub src/gtkarrow.c src/gtkarrow.stub src/gtkaspectframe.c src/gtkaspectframe.stub src/gtkbbox.c src/gtkbbox.stub src/gtkbin.c src/gtkbin.stub src/gtkbindings.c src/gtkbindings.stub src/gtkbox.c src/gtkbox.stub src/gtkbutton.c src/gtkbutton.stub src/gtkcalendar.c src/gtkcalendar.stub src/gtkcelleditable.c src/gtkcelleditable.stub src/gtkcelllayout.c src/gtkcelllayout.stub src/gtkcellrenderer.c src/gtkcellrenderer.stub src/gtkcellrenderercombo.c src/gtkcellrenderercombo.stub src/gtkcellrendererpixbuf.c src/gtkcellrendererpixbuf.stub src/gtkcellrendererprogress.c src/gtkcellrendererprogress.stub src/gtkcellrenderertext.c src/gtkcellrenderertext.stub src/gtkcellrenderertoggle.c src/gtkcellrenderertoggle.stub src/gtkcellview.c src/gtkcellview.stub src/gtkcheckbutton.c src/gtkcheckbutton.stub src/gtkcheckmenuitem.c src/gtkcheckmenuitem.stub src/gtkclipboard.c src/gtkclipboard.stub src/gtkclist.c src/gtkclist.stub src/gtkcolorbutton.c src/gtkcolorbutton.stub src/gtkcolorsel.c src/gtkcolorsel.stub src/gtkcolorseldialog.c src/gtkcolorseldialog.stub src/gtkcombo.c src/gtkcombo.stub src/gtkcombobox.c src/gtkcombobox.stub src/gtkcomboboxentry.c src/gtkcomboboxentry.stub src/gtkcontainer.c src/gtkcontainer.stub src/gtkctree.c src/gtkctree.stub src/gtkcurve.c src/gtkcurve.stub src/gtkdialog.c src/gtkdialog.stub src/gtkdnd.c src/gtkdnd.stub src/gtkdrawingarea.c src/gtkdrawingarea.stub src/gtkeditable.c src/gtkeditable.stub src/gtkentry.c src/gtkentry.stub src/gtkentrycompletion.c src/gtkentrycompletion.stub src/gtkenums.c src/gtkenums.stub src/gtkeventbox.c src/gtkeventbox.stub src/gtkexpander.c src/gtkexpander.stub src/gtkfilechooser.c src/gtkfilechooser.stub src/gtkfilechooserbutton.c src/gtkfilechooserbutton.stub src/gtkfilechooserdialog.c src/gtkfilechooserdialog.stub src/gtkfilechooserwidget.c src/gtkfilechooserwidget.stub src/gtkfilesel.c src/gtkfilesel.stub src/gtkfixed.c src/gtkfixed.stub src/gtkfontbutton.c src/gtkfontbutton.stub src/gtkfontsel.c src/gtkfontsel.stub src/gtkframe.c src/gtkframe.stub src/gtkgamma.c src/gtkgamma.stub src/gtkgc.c src/gtkgc.stub src/gtkhandlebox.c src/gtkhandlebox.stub src/gtkhbbox.c src/gtkhbbox.stub src/gtkhbox.c src/gtkhbox.stub src/gtkhpaned.c src/gtkhpaned.stub src/gtkhruler.c src/gtkhruler.stub src/gtkhscale.c src/gtkhscale.stub src/gtkhscrollbar.c src/gtkhscrollbar.stub src/gtkhseparator.c src/gtkhseparator.stub src/gtkiconfactory.c src/gtkiconfactory.stub src/gtkicontheme.c src/gtkicontheme.stub src/gtkiconview.c src/gtkiconview.stub src/gtkimage.c src/gtkimage.stub src/gtkimagemenuitem.c src/gtkimagemenuitem.stub src/gtkimcontext.c src/gtkimcontext.stub src/gtkimcontextsimple.c src/gtkimcontextsimple.stub src/gtkimmulticontext.c src/gtkimmulticontext.stub src/gtkinputdialog.c src/gtkinputdialog.stub src/gtkinvisible.c src/gtkinvisible.stub src/gtkitem.c src/gtkitem.stub src/gtkitemfactory.c src/gtkitemfactory.stub src/gtklabel.c src/gtklabel.stub src/gtklayout.c src/gtklayout.stub src/gtklist.c src/gtklist.stub src/gtklistitem.c src/gtklistitem.stub src/gtkliststore.c src/gtkliststore.stub src/gtkmain.c src/gtkmain.stub src/gtkmenu.c src/gtkmenu.stub src/gtkmenubar.c src/gtkmenubar.stub src/gtkmenuitem.c src/gtkmenuitem.stub src/gtkmenushell.c src/gtkmenushell.stub src/gtkmenutoolbutton.c src/gtkmenutoolbutton.stub src/gtkmessagedialog.c src/gtkmessagedialog.stub src/gtkmisc.c src/gtkmisc.stub src/gtknotebook.c src/gtknotebook.stub src/gtkobject.c src/gtkobject.stub src/gtkoldeditable.c src/gtkoldeditable.stub src/gtkoptionmenu.c src/gtkoptionmenu.stub src/gtkpaned.c src/gtkpaned.stub src/gtkpixmap.c src/gtkpixmap.stub src/gtkplug.c src/gtkplug.stub src/gtkpreview.c src/gtkpreview.stub src/gtkprogress.c src/gtkprogress.stub src/gtkprogressbar.c src/gtkprogressbar.stub src/gtkradioaction.c src/gtkradioaction.stub src/gtkradiobutton.c src/gtkradiobutton.stub src/gtkradiomenuitem.c src/gtkradiomenuitem.stub src/gtkradiotoolbutton.c src/gtkradiotoolbutton.stub src/gtkrange.c src/gtkrange.stub src/gtkrc.c src/gtkrc.stub src/gtkruler.c src/gtkruler.stub src/gtkscale.c src/gtkscale.stub src/gtkscrollbar.c src/gtkscrollbar.stub src/gtkscrolledwindow.c src/gtkscrolledwindow.stub src/gtkselection.c src/gtkselection.stub src/gtkseparator.c src/gtkseparator.stub src/gtkseparatormenuitem.c src/gtkseparatormenuitem.stub src/gtkseparatortoolitem.c src/gtkseparatortoolitem.stub src/gtksettings.c src/gtksettings.stub src/gtksignal.c src/gtksignal.stub src/gtksizegroup.c src/gtksizegroup.stub src/gtksocket.c src/gtksocket.stub src/gtkspinbutton.c src/gtkspinbutton.stub src/gtkstatusbar.c src/gtkstatusbar.stub src/gtkstock.c src/gtkstock.stub src/gtkstyle.c src/gtkstyle.stub src/gtktable.c src/gtktable.stub src/gtktearoffmenuitem.c src/gtktearoffmenuitem.stub src/gtktextbuffer.c src/gtktextbuffer.stub src/gtktextchild.c src/gtktextchild.stub src/gtktextiter.c src/gtktextiter.stub src/gtktextmark.c src/gtktextmark.stub src/gtktexttag.c src/gtktexttag.stub src/gtktexttagtable.c src/gtktexttagtable.stub src/gtktextview.c src/gtktextview.stub src/gtktipsquery.c src/gtktipsquery.stub src/gtktoggleaction.c src/gtktoggleaction.stub src/gtktogglebutton.c src/gtktogglebutton.stub src/gtktoggletoolbutton.c src/gtktoggletoolbutton.stub src/gtktoolbar.c src/gtktoolbar.stub src/gtktoolbutton.c src/gtktoolbutton.stub src/gtktoolitem.c src/gtktoolitem.stub src/gtktooltips.c src/gtktooltips.stub src/gtktreednd.c src/gtktreednd.stub src/gtktreemodel.c src/gtktreemodel.stub src/gtktreemodelfilter.c src/gtktreemodelfilter.stub src/gtktreemodelsort.c src/gtktreemodelsort.stub src/gtktreeselection.c src/gtktreeselection.stub src/gtktreesortable.c src/gtktreesortable.stub src/gtktreestore.c src/gtktreestore.stub src/gtktreeview.c src/gtktreeview.stub src/gtktreeviewcolumn.c src/gtktreeviewcolumn.stub src/gtktypeutils.c src/gtktypeutils.stub src/gtkuimanager.c src/gtkuimanager.stub src/gtkvbbox.c src/gtkvbbox.stub src/gtkvbox.c src/gtkvbox.stub src/gtkviewport.c src/gtkviewport.stub src/gtkvpaned.c src/gtkvpaned.stub src/gtkvruler.c src/gtkvruler.stub src/gtkvscale.c src/gtkvscale.stub src/gtkvscrollbar.c src/gtkvscrollbar.stub src/gtkvseparator.c src/gtkvseparator.stub src/gtkwidget.c src/gtkwidget.stub src/gtkwindow.c src/gtkwindow.stub src/pango-attributes.c src/pango-attributes.stub src/pango-break.c src/pango-break.stub src/pango-context.c src/pango-context.stub src/pango-coverage.c src/pango-coverage.stub src/pango-enum-types.c src/pango-enum-types.stub src/pango-font.c src/pango-font.stub src/pango-fontmap.c src/pango-fontmap.stub src/pango-fontset.c src/pango-fontset.stub src/pango-glyph.c src/pango-glyph.stub src/pango-item.c src/pango-item.stub src/pango-layout.c src/pango-layout.stub src/pango-types.c src/pango-types.stub src/test.log gauche-gtk-0.6+git20160927/COPYING000066400000000000000000000031061300401456300160370ustar00rootroot00000000000000;;-*- coding:utf-8 -*- Copyright (c) 2001-2010 Shiro Kawai Copyright (c) 2006-2007 Michal MaruÅ¡ka Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the authors nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. gauche-gtk-0.6+git20160927/ChangeLog000066400000000000000000000035001300401456300165540ustar00rootroot000000000000002016-09-27 Shiro Kawai * lib/h2s/parse.scm (parse-body): Fix for new Pango. https://github.com/shirok/Gauche-gtk2/issues/5 2015-06-24 Shiro Kawai * src/gauche-gtk.c (call_callback), lib/gtk.scm (%gtk-call-callback): Moved callback handling code to lib/gtk.scm, and allow to intercept error handler using parameter gtk-callback-error-handler. * lib/gtk/error-dialog.scm: Intercept error handler by gtk-callback-error-handler, instead of using Gauche's custom error reporter mechanism. Because of the change in Scm_ReportError, it'll doesn't make much sense to use the latter. 2012-04-02 Shiro Kawai * src/gtk-lib.hints (gtk-tree-model-get-column-type): Fixed mismatch of arguments - the function body referred to global function 'index' instead of the argument 'index_'. (gtk-ui-manager-add-ui-from-string): Use u_int instead of uint for the portability. Also fixed several places to suppress warnings. * src/gauche-gtk.h: Added a couple of missing prototypes. 2011-11-23 Akinori Hattori * src/h2s-gtk.scm: Added gdk-pixbuf-directory. * src/gtk-lib.hints: Fixed function redefinition errors. * lib/h2s/parse.scm: Skip preprocessor directive inside the enum definition. 2011-07-25 Shiro Kawai * lib/h2s/parse.scm (parse-struct): Strip GSEAL() macro for now, in order to keep the backward compatibility---some time near future we should discurage accessing gtk objects with slots. 2011-02-28 Shiro Kawai * src/h2s-gtk.scm (*header-search-paths*): Bail out with proper error message when gtk and pango development environment can't be found. 2010-05-25 Shiro Kawai * Imported CVS HEAD of Gauche-gtk and changed various parts to catch up the latest Gauche. gauche-gtk-0.6+git20160927/ChangeLog.0000066400000000000000000000425621300401456300167250ustar00rootroot000000000000002004-06-26 Shiro Kawai * release 0.4.1 * src/pango-lib.hints: expose PANGO_SCALE. * src/gdk-lib.hints (gdk-draw-polygon): make it accept both integer and boolean as 'filled' argument, in order to keep the old code working. 2004-06-24 Shiro Kawai * gdk-lib.hits (gdk-pixbuf-new-from-file, gdk-pixbuf-save, gdk-pixbuf-animat): fixed handling of GError arg. 2004-06-23 Shiro Kawai * h2stub.scm (ignore-field!, fix-field!): changed macro to evaluate the first arg, for consistency and convenience. (ignore-field-except!): new macro added. (*header-search-paths*): use "pkg-config --variable=includedir" for the systems that have gtk headers installed in unusual location. * gtk-lib.hints: fixes to make the distribution compilable as is on both Gtk-2.2.x and Gtk-2.4.x. * gdk-lib.hints: adopted ignore-field! 2004-06-22 Shiro Kawai * configure.in: src/Makefile.in: src/gauche-gtk.h: src/gdk-lib.hints: src/h2stub.scm: src/GDKPIXBUFFILES: Added gdk-pixbuf support 2004-06-04 Shiro Kawai * src/pango-lib.hints (pango-font-family-get-name): (pango-font-face-get-face-name): (pango-font-description-get-family): added missing APIs. * src/gdk-lib.hints (gdk-draw-polygon): 'filled' argument should be , but was . 2004-05-22 Shiro Kawai * gtkgl/Makefile.in: fixed installation directory of *.scm * glgd/Makefile.in: ditto. 2004-05-16 Shiro Kawai * configure.in : 0.4.1_pre1 2004-04-23 Shiro Kawai * Makefile.in, */Makefile.in : changed to use gauche-install script to install stuff. * configure.in : added a macro to generate Gauche-gtk.gpd. * mkinstalldirs : no longer needed. 2004-03-26 Shiro Kawai * gtk-lib.hints (gtk-binding-set-by-class): added entry. 2004-03-18 Shiro Kawai * release 0.4 * src/pango-lib.hints, src/gauche-gtk.h, src/gauche-gtk.c : more Pango supports. 2004-03-15 Shiro Kawai * src/h2stub.scm : allow more compact define-cproc-fix. recognizes GObject* as argument type. * src/gauche-gtk.h : added SCM_RETURNn (2 <= n <= 5) macros. * src/gdk-lib.hints, src/gtk-lib.hints: added some more API support. 2004-03-14 Shiro Kawai * glgd/glgdGraph.[ch], glgd/glgdlib.stub (glgd-graph-connect): dropped toplevel widget argument. * glgd/*.[ch] : fixed tabs, indents and comments. 2004-03-01 Shiro Kawai * glgd/glgdGraph.h, glgd/glgdGraph.c : fixed memory leak. * glgd/glgdNode.c (glgdNodeColorDefault): dropped 'node' argument, for it isn't used. 2004-02-29 Shiro Kawai * glgd/glgdNode.c (glgdNodeDataGet, glgdNodeInfoGet): fixed a bug that returned NULL (should be SCM_FALSE). 2004-02-25 Shiro Kawai * src/configure.in : bumped version to 0.4_pre1. * src/README : added some information about glgd. 2004-02-10 Shiro Kawai * src/pango-lib.hints, src/h2stub.scm : added some more support for pango attributes. 2004-02-09 Shiro Kawai * lib/gtk/glgd.scm (): start adding higher-level API. * lib/gtk/gtkgl.scm (with-gtkgl-context): added for convenience. * lib/Makefile.in, gtkgl/Makefile.in, glgd/Makefile.in: moved installation command of gtkgl.scm and glgd.scm to their own Makefiles. 2004-01-28 Shiro Kawai * src/h2stub.scm (ignore-field!): added to ignore certain fields safely. * src/gtk-lib.hints (): use ignore-field! instead of fix-field!, so that it works with gtk versions that doesn't have the named field. 2004-01-26 Shiro Kawai * src/gauche-gtk.c (Scm_UnboxGValue): removed duplicated code. 2003-12-16 Shiro Kawai * release 0.3.2 2003-12-09 Shiro Kawai * src/gtk-lib.hints (gtkaccelgroup), src/gauche-gtk.c(Scm_UnboxGValue): support for accelerators API and gtk-window-get-size (Patch from Michal Maru-B¹ka).$)B 2003-12-04 Shiro Kawai * src/gauche-gtk.c (Scm_RegisterFinalizer): removed the old cruft. 2003-10-09 Shiro Kawai * */Makefile.in : cleaned up install rules, and make sure to create destination directory, by mkinstalldirs. 2003-10-08 Shiro Kawai * src/gtk-lib.hints (): disable client_window slot, for it appears dropped in gtk-2.2.4. 2003-10-04 Shiro Kawai * release 0.3.1 * */Makefile.in: updated make targets to follow the modern convention (test -> check, realclean -> maintainer-clean). * examples/gdk-animation.scm : changed gdk-draw-rectangle's third arg from integer to boolean, to follow gtk-2.2. 2003-07-14 Shiro Kawai * */Makefile.in: added DESTDIR to installation target directory 2003-07-13 Shiro Kawai * src/gtk-lib.hints (): Removed disable-scroll-on-focus field from , for it doesn't exist any longer in Gtk-2.2.2. (Thanks to Erik Greenwald for notifying this) 2003-06-06 Shiro Kawai * src/gauche-gtk.c (predef_types): map Scheme to G_TYPE_INT instead of G_TYPE_LONG, in order to manipulate integer column in tree view, for example. (Patch from Alex Shinn). 2003-05-10 Shiro Kawai * src/gauche-gtk.c (Scm_Init_gauche_gtk): fixed a typo in the name of class. (Patch from Kimura Fuyuki). 2003-02-10 Shiro Kawai * release 0.3 2003-02-09 Shiro Kawai * gtkgl/gdkglext.stub, gtkgl/gtkglext.stub: adapted to gtkglext 0.7. 2003-01-29 Shiro Kawai * src/gtk-lib.hints : removed some fields and procedures deprecated in Gtk-2.2, according to the patch from Alex Shinn. * Minor compiler wanings removed by patch from YOKOTA Hiroshi. * examples/gtkglext/gears.scm : Backface culling bug fixed. Idle handler bug fixed to save CPU usage. Correct normal vector at outward faces of teeth. (patch from YOKOTA Hiroshi). 2003-01-19 Shiro Kawai * src/gauche-glib.stub : added g-object-{get|set}-property. 2003-01-14 Shiro Kawai * src/h2stub.scm : fixed define-cclass generation for GObjects to give a correct C instance type. 2002-12-30 Shiro Kawai * README, src/gtkgl/Makefile.in, src/gtkgl/gauche-gtkgl.h : adapted to gtkgl-0.6.1 (patch provided by Kimura Fuyuki). 2002-12-28 Shiro Kawai * src/gauche-gtk.[ch], src/gauche-glib.stub : revised memory management code. See the discussion near the beginning of gauche-gtk.c. Until the 'proper' mark procedure is implemented, I rely on the explicit destruction of gtk objects; that is, once a is created, it will never be reclaimed unless gtk-object-destroy or g-object-unref is issued on it. 2002-12-25 Shiro Kawai * src/gauche-gtk.c (Scm_Init_gauche_gtk): added missing gdklib initialization (patch from Kimura Fuyuki). Also fixed a bug in Scm_MakeGdkPointVector etc (size wasn't initialized). 2002-12-23 Shiro Kawai * src/h2stub.scm : added support to specify direct-slots for gtk classes that uses multiple inheritance (`interface', in Gtk term). This change requires Gauche support---see the 12/23 entry of Gauche/Changelog. * src/gtk-lib.hints : added direct-slots specification (add-mixin!) for some classes. * src/test-gtk.scm : added. 2002-12-22 Shiro Kawai * src/gauche-gtk.[ch], src/h2stub.scm : made classes base class, i.e. Scheme subclasses can be defined. Requires the newest CVS snapshot of Gauche. 2002-12-19 Shiro Kawai * src/gtk-lib.hints : added missing gtk-tree-view-get-columns. 2002-12-15 Shiro Kawai * release 0.2.4 2002-11-29 Shiro Kawai * src/gtk-lib.hints : added APIs. 2002-11-28 Shiro Kawai * example/gdk-animation.scm : added. 2002-11-27 Shiro Kawai * src/gtk-lib.hints : added more gtk-tree-model APIs, fixed gtk-tree-view-set-cursor. 2002-11-22 Shiro Kawai * lib/gtk/listener.scm (gtk-scheme-listener-add) : allow caller to specify finalizer. It is called after the gtk input is removed. 2002-11-20 Shiro Kawai * release 0.2.3 * src/gauche-gtk.[ch] (SCM_GOBJECT_BOX): The macro evaluated its argument twice, causing some stub-generated code to call widget constructors twice. Fixed. * src/gtk-lib.hints: added gtk-dialog-new-with-buttons * lib/gtk/error-dialog.scm : rewritten using gtk-dialog 2002-11-15 Shiro Kawai * release 0.2.2 2002-11-12 Shiro Kawai * lib/gtk/error-dialog.scm : added 2002-10-31 Shiro Kawai * src/h2stub.scm (): added c-copy-proc for indirect opaque type. * src/gtk-lib.hints : fixed GtkTreePath using c-copy-proc 2002-10-30 Shiro Kawai * src/gauche-gtk.c : support conversion of GtkTreePath->ScmObj 2002-10-29 Shiro Kawai * src/gtk-lib.hints : added support of gtk-tree-store 2002-10-21 Shiro Kawai * src/gtk-lib.hints : added support for gtk-tree-selection. fixed some GValue handling. added gtk-input-add. fixed a bug in gtk-radio-menu-item-set-group. * lib/gtk/listeter.scm : added listener. 2002-10-20 Shiro Kawai * src/gtk-lib.hints (gtk-kayout-new): fixed. 2002-10-18 Shiro Kawai * src/gtk-lib.hints : added gtk-combo-set-popdown-strings. 2002-10-05 Shiro Kawai * src/gtk-lib.hints : added gtk-widget-style-get-property. 2002-10-04 Shiro Kawai * src/gtk-lib.hints : added gtk-widget-get-pointer and gtk-widget-translate-coordinates support. 2002-10-03 Shiro Kawai * src/gauche-gtk.c : fixed improper use of g_value_set_pointer; they should be g_value_set_object. 2002-09-24 Shiro Kawai * release 0.2.1 * src/gtk-lib.hints : added gtk-radio-menu-item support * src/h2stub.scm : use file-equal? instead of calling external diff 2002-09-13 Shiro Kawai * src/gtk-lib.hints (gtk-file-selection-get-filename): fixed typo that prevented from compiling under UTF-8 configuration. (Thanks to TAGA Yoshitaka). 2002-09-12 Shiro Kawai * release 0.2 * src/gauche-gtk.c, src/gauche-gtk.h : added #ifdefs to make gauche-gtk work for both Gauche 0.6.2 and Gauche 0.6.3. 2002-09-08 Shiro Kawai * lib/gen-keysyms.scm : nope, the idea of compiling keysym symbol binding into doesn't work good, for gcc consumes too much memory to compile large number of static data. It's much simpler to make the definition a Scheme script and read it at runtime. This change also reverts the addition of two files below. * src/genstub.fix : a patched genstub that fixes a problem of Gauche 0.6.2's genstub that generates all-lower-case C name for the constant symbol---so it couldn't have (define-enum GDK_A) and (define-enum GDK_a) simultaneously. * src/gdk-keysyms.stub : gdk keysyms definitions. included from gauche-gdklib.stub. 2002-09-07 Shiro Kawai * src/gauche-gtkgl*, gtkgl/* : switched to gtkglext from gtkglarea, and moved related sources to separate directory gtkgl. * src/pango-lib.hints : added as an opaque object. * src/gauche-glib.stub, src/gauche-gtk.[ch] : added support. * examples/gtkglext/* : added a couple of examples. 2002-09-06 Shiro Kawai * release 0.1 * Makefile.ins : small fixes for release. * src/gauche-gdklib.stub, src/gauche-gtk.c : completed gdk structure arrays. * src/gdk-lib.hints : fixed gdk-color handling * examples/{spinbutton,statusbar,wheelbarrow}.scm : added * examples/* : moved to examples/gtk-tutorial, and added copyright notice. 2002-09-05 Shiro Kawai * src/gauche-gtk.c : fixed ScmClass -> GType mapping, and StringListToStringArray. * src/gtk-lib.hints : added gtktextbuffer support. * src/gdk-lib.hints : added gdkpixmap support. * lib/gtk/gtkaux.scm : added. Some GTk APIs are easier to be written in Scheme (esp., varargs equivalent) * examples/{paned,pixmap,progressbar,rangewidgets,scrolledwin}.scm : added 2002-09-04 Shiro Kawai * src/h2stub.scm : made it deal with array fields. 2002-09-03 Shiro Kawai * src/gtk-lib.hints, src/h2stub.scm, src/gauche-gtk.[ch]: added support of gtk-tree-view, gtk-tree-model, etc. Reorganized h2stub to handle opaque type conveniently. 2002-08-31 Shiro Kawai * src/h2stub.scm : allow adding raw code in hints file * src/gtk-lib.hints : added support of gtk-menu and gtk-list-store. * src/gauche-gtk.[ch] : added more functions for GValue/ScmObj and GType/ScmClass conversion procs. * examples/{menu,notebook}.scm : added 2002-08-30 Shiro Kawai * configure.in, src/Makefile.in, src/gauche-gtkgl.[ch], src/gauche-gtkgl.stub : added GtkGLArea support (not finished yet). * src/gtk-config.h.in : added * src/h2stub.scm : more flexible fields support. * src/gtk-lib.hints : added support of gtk-list. * examples/list.scm : added 2002-08-29 Shiro Kawai * src/h2stub.scm : added types that allows NULL (in Scheme #t). * src/gauche-gtk.c : fixed handling of GObject <-> ScmObj association. Now it is bidirectional. GObject has a property that points back to ScmObj. A Scheme property list is associated to ScmGObject, as an alternative of g_object_{get|set}_data. * src/gauche-glib.stub : renamed from gauche-gsignal.stub, for it has g-object-set-data and g-object-get-data. * examples/{fixed,frame,label}.scm : added * src/gtk-lib.hints : added support of gtk-frame. 2002-08-28 Shiro Kawai * src/h2stub.scm : generate initialization call in gtk-lib.inits in the right order considering class dependencies, so that the inherited slots can be initialized correctly. * src/gauche-gtk.c (Scm_BoxGValue) : handle G_TYPE_INVALID case. * src/gtk-lib.hints : added support of gtk-file-selection. * examples/{entry,eventbox,filesel}.scm : added 2002-08-27 Shiro Kawai * src/h2stub.scm : make the code generator not to overwrite the output file if there's no changes in it. Also start using gauche.mop.instance-pool. Also construct CPL before loading hints file, so that the hints file can modify CPL (needed by adding abstract class GtkEditable etc. to CPL of GtkEntry etc.). * src/gtk-lib.stub : added partial supports to gtkentry, gtkeditable, gtklabel, gtkcalendar. * src/gdk-lib.stub : fixed gdkevent part according to h2stub change. 2002-08-26 Shiro Kawai * examples/* : added more examples * src/gtk-lib.hints : added string constants of gtkstock. * src/h2stub.scm : search gtk header files more flexibly. 2002-08-19 Shiro Kawai * src/gauche-gtk.c (Scm_GtkInitUnixSignalHook): added hook to let Gauche handle unix signals inside gtk-main-loop. 2002-08-18 Shiro Kawai * src/gauche-gkt.h, src/gauche-gtk.c, src/gtk-lib.hints : finishing and support. 2002-08-17 Shiro Kawai * src/gauche-gtk.h, src/gauche-gtk.c : adding (not finished). * src/h2stub.scm : allow additional 'define-cproc' and 'define-cclass' in hints files. 2002-08-15 Shiro Kawai * examples/* : added more examples * src/gauche-gtk.c : removed debug stubs 2002-08-06 Shiro Kawai * h2stub.scm : added indirect? flag to to support boxed types that has separate data chunk (like GdkEvent). 2002-08-05 Shiro Kawai * src/gauche-gtk.c : added GdkEvent <-> GValue conversion routine. * example/hello2.scm : added 2002-08-02 Shiro Kawai * src/gauche-gtk.c, src/gauche-gsignal.stub : added GSignal interface. 2002-08-01 Shiro Kawai * src/gauche-gtk.h, src/gauche-gtk.c : added registration mechansim of callback functions. 2002-07-30 Shiro Kawai * src/gauche-gtk.c : cleaned up GType <-> ScmClass mapping. * src/h2stub.scm, src/gtk-lib.hints, GTKFILES : passes compilation. * src/Makefile.in : separated stub generation and normal compilation. 2002-07-29 Shiro Kawai * src/h2stub.scm : allow definition of opaque gobjects. * src/pango-lib.hints, PANGOFILES : start adding Pango stuff. 2002-07-28 Shiro Kawai * src/h2stub.scm : added some predefined types * src/gdk-lib.hints : more hints. * src/gtk-lib.hints : added 2002-07-25 Shiro Kawai * src/h2stub.scm, configure.in, src/GDKFILES, src/GTLFILES: more stuff for autogeneration. * src/types2h.scm : removed, for h2stub.scm does the job. 2002-07-24 Shiro Kawai * src/h2stub.scm : start writing this. This parses gtk *.h files to generate *.types, *.stub and *.h. 2002-07-23 Shiro Kawai * src/types2h.scm : now gdklib.h is auto-generated from gdklib.types by this script. * src/gauche-gdk.h : split manually-defined gdk object wrappers here. 2002-07-22 Shiro Kawai * adding gdk stuff 2002-07-21 Shiro Kawai * imported initial sources gauche-gtk-0.6+git20160927/ChangeLog.mmc000066400000000000000000000043711300401456300173360ustar00rootroot00000000000000 [13 gen 07] glgd/Makefile.in Added pkg-config --cflags freetype2 g-object-class-find-property todo: * Check gtk_major_version gtk_minor_version gtk_micro_version gtk_binary_age gtk_interface_age http://developer.gnome.org/doc/API/2.4/gtk/gtk-Feature-Test-Macros.html extern const guint gtk_major_version; extern const guint gtk_minor_version; extern const guint gtk_micro_version; extern const guint gtk_binary_age; extern const guint gtk_interface_age; gchar* gtk_check_version (guint required_major, guint required_minor, guint required_micro); #define GTK_MAJOR_VERSION #define GTK_MINOR_VERSION #define GTK_MICRO_VERSION #define GTK_BINARY_AGE #define GTK_INTERFACE_AGE #define GTK_CHECK_VERSION (major,minor,micro) 2006-01-14 Michal MaruÅ¡ka * releasing 0.5.3 * src/gdk-lib.hints: gdk-pixbuf-loader new functions gdk-pixbuf-loader-write and - GdkPixbufFormat gdk-pixbuf-get-formats now works! ISSUE: Scm_GoSListToList depends on the list being of GObjects So, if it is list of other C objects (as in case Formats) an ad-hoc converter is needed. * src/gauche-gtk.c: Scm_g_signal_emit now works with arguments to signals. - Enums can be boxed. gauche-gtk-0.6+git20160927/DIST000077500000000000000000000024211300401456300154740ustar00rootroot00000000000000#!/bin/sh TGZ_DEST="$HOME/shiro.dreamhost.com/scheme/vault/" MAN_DEST="$HOME/shiro.dreamhost.com/scheme/gauche/man/" CHANGELOG_DEST="$HOME/shiro.dreamhost.com/scheme/gauche/ChangeLog.Gauche-gtk.txt" while [ $# -gt 0 ]; do case $1 in gen) gen=yes; shift;; doc) docs=yes; shift ;; tgz) tgz=yes; shift ;; test) test=yes; shift ;; testclean) testclean=yes; shift ;; *) echo "DIST [doc][tgz][test][testclean]"; exit 0;; esac done if [ "$gen" = "yes" ]; then autoconf -I `gauche-config --ac` fi if [ "$tgz" = "yes" ]; then if [ -f Makefile ]; then make maintainer-clean; fi autoconf -I `gauche-config --ac` ./configure if [ ! -f VERSION ]; then echo "No VERSION; something wrong?"; exit 1; fi VERSION=`cat VERSION` # (cd doc; make html) (cd src; make stubs) # escm -o INSTALL INSTALL.esc # LANG=ja_JP escm -o INSTALL.eucjp INSTALL.esc make distclean rm -rf ../Gauche-gtk-$VERSION rm -f DIST_EXCLUDE_X cat DIST_EXCLUDE > DIST_EXCLUDE_X find . -name CVS -print -prune >> DIST_EXCLUDE_X mkdir ../Gauche-gtk-$VERSION tar cvfX - DIST_EXCLUDE_X . | (cd ../Gauche-gtk-$VERSION; tar xf -) (cd ..; tar cvf - Gauche-gtk-$VERSION | gzip -9 > Gauche-gtk-$VERSION.tgz) # mv ../Gauche-gtk-$VERSION.tgz $TGZ_DEST # cp ChangeLog $CHANGELOG_DEST fi gauche-gtk-0.6+git20160927/DIST_EXCLUDE000066400000000000000000000000731300401456300166430ustar00rootroot00000000000000AUTOCONF DIST DIST_EXCLUDE DIST_EXCLUDE_X INSTALL.esc .git gauche-gtk-0.6+git20160927/Makefile.in000066400000000000000000000041611300401456300170530ustar00rootroot00000000000000SHELL = @SHELL@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ datarootdir = @datarootdir@ srcdir = @srcdir@ VPATH = $(srcdir) top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ # These may be overridden by make invocators DESTDIR = OPTFLAGS = @OPTFLAGS@ GOSH = @GOSH@ GAUCHE_CONFIG = @GAUCHE_CONFIG@ GAUCHE_PACKAGE = @GAUCHE_PACKAGE@ INSTALL = @GAUCHE_INSTALL@ # Other parameters SOEXT = @SOEXT@ OBJEXT = @OBJEXT@ EXEEXT = @EXEEXT@ LOCAL_PATHS = @LOCAL_PATHS@ HAVE_GTKGL=@GTKGL_SO@ HAVE_GLGD=@GLGD_SO@ # Module-specific stuff PACKAGE = Gauche-gtk2 CONFIG_GENERATED = Makefile $(PACKAGE).gpd \ config.cache config.log config.status \ autom4te*.cache GAUCHE_PKGINCDIR = $(DESTDIR)@GAUCHE_PKGINCDIR@ GAUCHE_PKGLIBDIR = $(DESTDIR)@GAUCHE_PKGLIBDIR@ GAUCHE_PKGARCHDIR = $(DESTDIR)@GAUCHE_PKGARCHDIR@ .PHONY: all check clean install distclean maintainer-clean stubs all : cd src; $(MAKE) all cd lib; $(MAKE) all if test X$(HAVE_GTKGL) != X; then (cd gtkgl; $(MAKE) all); fi if test X$(HAVE_GLGD) != X; then (cd glgd; $(MAKE) all); fi check : all cd src; $(MAKE) check if test X$(HAVE_GTKGL) != X; then (cd gtkgl; $(MAKE) check); fi if test X$(HAVE_GLGD) != X; then (cd glgd; $(MAKE) check); fi stubs : cd src; $(MAKE) stubs clean : rm -rf core *~ cd src; $(MAKE) clean cd lib; $(MAKE) clean cd gtkgl; $(MAKE) clean cd glgd; $(MAKE) clean distclean : clean cd src; $(MAKE) distclean cd lib; $(MAKE) distclean cd gtkgl; $(MAKE) distclean cd glgd; $(MAKE) distclean rm -rf $(CONFIG_GENERATED) install : cd src; $(MAKE) install cd lib; $(MAKE) install $(INSTALL) -m 444 -T $(GAUCHE_PKGLIBDIR)/.packages Gauche-gtk2.gpd if test X$(HAVE_GTKGL) != X; then (cd gtkgl; $(MAKE) install); fi if test X$(HAVE_GLGD) != X; then (cd glgd; $(MAKE) install); fi maintainer-clean : clean cd src; $(MAKE) maintainer-clean cd lib; $(MAKE) maintainer-clean cd gtkgl; $(MAKE) maintainer-clean cd glgd; $(MAKE) maintainer-clean rm -rf configure VERSION $(CONFIG_GENERATED) gauche-gtk-0.6+git20160927/README000066400000000000000000000137701300401456300156740ustar00rootroot00000000000000This is a Gauche extension module to use GTK. Scheme binding is mostly generated automatically by parsing GTK header files. There are missing APIs and fields. There are also some APIs that are converted incorrectly. In worst case, you'll get core dump with some APIs of which stub code treats pointers incorrectly. If you find any deficiencies, please report them to the author (If you're a member of gauche-devel mailing list, you can post bug reports there. If you're not, you can directly send them to shiro at acm dot org). The current version passes Scheme strings to Gtk as is; it works OK if Gauche's native character encoding is UTF-8. If you compiled Gauche with other native character encodings, do not pass characters other than ASCII. This restriction will be removed in future versions, in which the strings will be automatically converted. [Requirements] - Gauche 0.9 or later - Gtk 2.10 or later. These can be downloaded from http://www.gtk.org/ . Gtk 1.x is not supported. - pkgconfig-0.12 or later. If you have gtk2, you should already have it. - Optionally, you can build GtkGLExt binding with Gauche-gtk. If you want it, you need gtkglext-0.6.0 or later. It can be downloaded from http://gtkglext.sourceforge.net/ . You'd want to have Gauche-gl as well to use gtkglext. - Additionally, you can build a GLGD widget, which draws a graph using OpenGL using GtkGLExt. - If you try to build from the git repository instead of tarball, you also need autoconf 2.54 or later. [Building from tarball] % ./configure % make % make install "Configure" script finds the location of Gauche and Gtk2. If you have gtkglext and want to build its binding, run configure as this: % ./configure --enable-gtkgl If you also want to build glgd (experimental), run configure as this (it implies --enable-gtkgl). % ./configure --enable-glgd GLGD uses Pango to display multilingual text on the OpenGL screen. If you want this feature, configure like this instead: % ./configure --enable-glgd-pango This uses PangoFT2. I hope it works on recent Linux distributions if you've set up font stuff correctly. It'd be hassle to make it work unless you have XFree86 4.3 or later. [Building from git repo] The source repository does not have machine-generated files. Large number of *.stub files are autogenerated ones, and you need to run 'make' for a separate target, 'make stubs', to generate them. % autoconf % ./configure [configure options ... see above] % make stubs ... lots of messages ... % make % make install [Usage] You can find some Scheme scripts ported from GTK examples under 'examples/gtk-tutorial' directory. There are also a few gtkglext examples under examples/gtkglext. Most GTK/GDK/Pango classes and functions are mapped straightforward to Scheme. GTK class becomes Scheme class. For example, C: struct GtkWidget --> Scheme class: C: struct GtkVBox --> Scheme class: Generally, fields of C structures are visible as slots in Scheme class. Some fields are read-only. Some fields are invisible from Scheme, usually because the proper accessor function hasn't been written. NOTE: Some fields are visible from Scheme but shouldn't be. Don't rely too much on such fields; eventually the 'private' fields will be hidden from Scheme. The rule of thumb is that if the GTk manual lists the field, then it'll always be available from Scheme. NOTE: Some Gtk structures have array fields. Currently, you can view such fields as vectors from Scheme, but you can't modify them. A special getter/setter for such fields will be provided. Scheme procedures generally take the same arguments as C version, with straightforward mapping. C: GtkVBox *gtk_vbox_new(gboolean homogenous, gint spacing) Scheme: (gtk-vbox-new ) => If C version has 'out' arguments, i.e. the pointer arguments to receive values from callee, the Scheme version returns such values as an extra return values. C: gboolean gtk_get_current_event_state(GdkModifierType *type) Scheme: (gtk-get-modifier-type) => , C: void gtk-misc-get-padding(GtkMisc *misc, gint *xpad, gint *ypa) Scheme: (gtk-misc-get-padding ) => , Some GTK functions take a function pointer along a user data, to mimic a closure. In Scheme, such procedures just take a closure. An important note for memory management: once Scheme obtains a pointer to a GTk object, the GTk object won't be reclaimed automatically. Instead, it should be destroyed explicitly, by gtk-object-destroy. GTk objects tend to require heavyweight finalization, and it is not a good idea to let Gauche's GC handle it. (Alternatively, you can call g-object-unref to tell GTk that you won't use that GTk object from Scheme anymore. GTk's reference counting mechanism then handles object management properly). Once a GTk object is destroyed, all Scheme pointers that have referred the object becomes 'unreferenced' state. Trying to use such Scheme pointers signals an error. You can check if the Scheme pointer is in unreferenced state by g-object-unreferenced? procedure. More specific tweaks: * g_signal_connect : the function takes a closure (and no user data), so there's no 'swapped' variant. * g_object_get_data, g_object_set_data : It is available in Scheme, but Scheme data is stored in the different location than GObject data. You can pass arbitrary Scheme object as a key, so there's no g_object_{get|set}_qdata. If you're not sure about the specific API, take a look at the corresponding stub file (e.g. gtkentry.stub for GtkEntry) in the source directory. [Interactive development] Usually you have to call gtk-main to make Gtk widgets work, which is not very convenient for interactive development. A new module gtk.listener is added from Gauche-gtk 0.2.2 which supports interative repl even while gtk-main is running. To use listener, you simply need to call (gtk-scheme-listener-add) before calling gtk-main. You'll get Scheme prompt. gauche-gtk-0.6+git20160927/config.guess000077500000000000000000001274401300401456300173340ustar00rootroot00000000000000#! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. timestamp='2005-05-27' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program 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 # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Per Bothner . # Please send patches to . Submit a context # diff and a properly formatted ChangeLog entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # # The plan is that this can be called by configure scripts if you # don't specify an explicit build system type. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d -q "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown if [ "${UNAME_SYSTEM}" = "Linux" ] ; then eval $set_cc_for_build cat << EOF > $dummy.c #include #ifdef __UCLIBC__ # ifdef __UCLIBC_CONFIG_VERSION__ LIBC=uclibc __UCLIBC_CONFIG_VERSION__ # else LIBC=uclibc # endif #else LIBC=gnu #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep LIBC= | sed -e 's: ::g'` fi # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep __ELF__ >/dev/null then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; amd64:OpenBSD:*:*) echo x86_64-unknown-openbsd${UNAME_RELEASE} exit ;; amiga:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit ;; cats:OpenBSD:*:*) echo arm-unknown-openbsd${UNAME_RELEASE} exit ;; hp300:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit ;; luna88k:OpenBSD:*:*) echo m88k-unknown-openbsd${UNAME_RELEASE} exit ;; mac68k:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit ;; macppc:OpenBSD:*:*) echo powerpc-unknown-openbsd${UNAME_RELEASE} exit ;; mvme68k:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit ;; mvme88k:OpenBSD:*:*) echo m88k-unknown-openbsd${UNAME_RELEASE} exit ;; mvmeppc:OpenBSD:*:*) echo powerpc-unknown-openbsd${UNAME_RELEASE} exit ;; sgi:OpenBSD:*:*) echo mips64-unknown-openbsd${UNAME_RELEASE} exit ;; sun3:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit ;; *:OpenBSD:*:*) echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerppc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` exit ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm:riscos:*:*|arm:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:SunOS:5.*:*) echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[45]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then # avoid double evaluation of $set_cc_for_build test -n "$CC_FOR_BUILD" || eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep __LP64__ >/dev/null then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; i*:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; x86:Interix*:[34]*) echo i586-pc-interix${UNAME_RELEASE}|sed -e 's/\..*//' exit ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; arm*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; cris:Linux:*:*) echo cris-axis-linux-${LIBC} exit ;; crisv32:Linux:*:*) echo crisv32-axis-linux-${LIBC} exit ;; frv:Linux:*:*) echo frv-unknown-linux-${LIBC} exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; mips:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef mips #undef mipsel #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=mipsel #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=mips #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;; mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef mips64 #undef mips64el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=mips64el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=mips64 #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;; ppc:Linux:*:*) echo powerpc-unknown-linux-${LIBC} exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-${LIBC} exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null if test "$?" = 0 ; then LIBC="gnulibc1" ; fi echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-${LIBC} ;; PA8*) echo hppa2.0-unknown-linux-${LIBC} ;; *) echo hppa-unknown-linux-${LIBC} ;; esac exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-${LIBC} exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-${LIBC} exit ;; i*86:Linux:*:*) # The BFD linker knows what the default object file format is, so # first see if it will tell us. cd to the root directory to prevent # problems with other programs or directories called `ld' in the path. # Set LC_ALL=C to ensure ld outputs messages in English. ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ | sed -ne '/supported targets:/!d s/[ ][ ]*/ /g s/.*supported targets: *// s/ .*// p'` case "$ld_supported_targets" in elf32-i386) TENTATIVE="${UNAME_MACHINE}-pc-linux-${LIBC}" ;; a.out-i386-linux) echo "${UNAME_MACHINE}-pc-linux-${LIBC}aout" exit ;; coff-i386) echo "${UNAME_MACHINE}-pc-linux-${LIBC}coff" exit ;; "") # Either a pre-BFD a.out linker (linux-gnuoldld) or # one that does not give us useful --help. echo "${UNAME_MACHINE}-pc-linux-${LIBC}oldld" exit ;; esac if [ "$LIBC" != "gnu" ] ; then echo "$TENTATIVE" && exit 0 ; fi # Determine whether the default compiler is a.out or elf eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include #ifdef __ELF__ # ifdef __GLIBC__ # if __GLIBC__ >= 2 LIBC=gnu # else LIBC=gnulibc1 # endif # else LIBC=gnulibc1 # endif #else #ifdef __INTEL_COMPILER LIBC=gnu #else LIBC=gnuaout #endif #endif #ifdef __dietlibc__ LIBC=dietlibc #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=` test x"${LIBC}" != x && { echo "${UNAME_MACHINE}-pc-linux-${LIBC}" exit } test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; } ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i386. echo i386-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown case $UNAME_PROCESSOR in *86) UNAME_PROCESSOR=i686 ;; unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NSE-?:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gauche-gtk-0.6+git20160927/config.sub000077500000000000000000000763231300401456300170020ustar00rootroot00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. timestamp='2005-06-02' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Please send patches to . Submit a context # diff and a properly formatted ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-dietlibc | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | \ kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray) os= basic_machine=$1 ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx | dvp \ | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | m32r | m32rle | m68000 | m68k | m88k | maxq | mcore \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64vr | mips64vrel \ | mips64orion | mips64orionel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64r5900 | mips64r5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | ms1 \ | msp430 \ | ns16k | ns32k \ | openrisc | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ | pyramid \ | sh | sh[1234] | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b \ | strongarm \ | tahoe | thumb | tic4x | tic80 | tron \ | v850 | v850e \ | we32k \ | x86 | xscale | xscalee[bl] | xstormy16 | xtensa \ | z8k) basic_machine=$basic_machine-unknown ;; m32c) basic_machine=$basic_machine-unknown ;; m6811 | m68hc11 | m6812 | m68hc12) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64vr-* | mips64vrel-* \ | mips64orion-* | mips64orionel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64r5900-* | mips64r5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | ms1-* \ | msp430-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ | pyramid-* \ | romp-* | rs6000-* \ | sh-* | sh[1234]-* | sh[23]e-* | sh[34]eb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ | tahoe-* | thumb-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tron-* \ | v850-* | v850e-* | vax-* \ | we32k-* \ | x86-* | x86_64-* | xps100-* | xscale-* | xscalee[bl]-* \ | xstormy16-* | xtensa-* \ | ymp-* \ | z8k-*) ;; m32c-*) ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; c90) basic_machine=c90-cray os=-unicos ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16c) basic_machine=cr16c-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mipsEE* | ee | ps2) basic_machine=mips64r5900el-scei case $os in -linux*) ;; *) os=-elf ;; esac ;; iop) basic_machine=mipsel-scei os=-irx ;; dvp) basic_machine=dvp-scei os=-elf ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; mvs) basic_machine=i370-ibm os=-mvs ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; or32 | or32-*) basic_machine=or32-unknown os=-coff ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc) basic_machine=powerpc-unknown ;; ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tic54x | c54x*) basic_machine=tic54x-unknown os=-coff ;; tic55x | c55x*) basic_machine=tic55x-unknown os=-coff ;; tic6x | c6x*) basic_machine=tic6x-unknown os=-coff ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh3 | sh4 | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sh64) basic_machine=sh64-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* | -openbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* \ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -linux-gnu* | -linux-uclibc* | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* | -skyos* \ | -irx* ) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -kaos*) os=-kaos ;; -zvmoe) os=-zvmoe ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 # This also exists in the configure program, but was not the # default. # os=-sunos4 ;; m68*-cisco) os=-aout ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gauche-gtk-0.6+git20160927/configure.ac000066400000000000000000000066471300401456300173070ustar00rootroot00000000000000dnl dnl Configuring gauche-gtk2 dnl process this file with autoconf to generate 'configure'. dnl AC_PREREQ(2.54) AC_INIT(Gauche-gtk2, 0.6_pre1, shiro@acm.org) AC_CONFIG_HEADER(src/gtk-config.h) AC_CANONICAL_SYSTEM dnl Replace @LOCAL_PATHS@ by --with-local option. AC_ARG_WITH(local, AC_HELP_STRING([--with-local=PATH:PATH...], [For each PATH, add PATH/include to the include search paths and PATH/lib to the library search paths. Useful if you have some libraries installed in non-standard places. ]), [ case $with_local in yes|no|"") ;; #no effect *) LOCAL_PATHS=$with_local ;; esac ]) AC_SUBST(LOCAL_PATHS) # options for configure scripts AC_ARG_ENABLE(gtkgl, AC_HELP_STRING([--enable-gtkgl], [Enable gtkglext interface.]), [ AC_DEFINE(HAVE_GTKGL, 1) GTKGL_SO="gauche-gtkgl.so" GTKGL_LIB="-lgtkgl"; GTKGL_SCM="gtk/gtkgl.scm"; PANGOFT2_LIB="" ]) AC_ARG_ENABLE(glgd, AC_HELP_STRING([--enable-glgd], [Enable glgd interface.]), [ AC_DEFINE(HAVE_GTKGL, 1) AC_DEFINE(HAVE_GLGD, 1) GTKGL_SO="gauche-gtkgl.so" GTKGL_LIB="-lgtkgl"; GTKGL_SCM="gtk/gtkgl.scm" PANGOFT2_LIB=""; GLGD_SO="gauche-glgd.so" GLGD_LIB="-lglgd"; GLGD_SCM="gtk/glgd.scm" ]) AC_ARG_ENABLE(glgd-pango, AC_HELP_STRING([--enable-glgd-pango], [Enable glgd interface with Pango.]), [ AC_DEFINE(HAVE_GTKGL, 1) AC_DEFINE(HAVE_GLGD, 1) AC_DEFINE(HAVE_GLGD_PANGO, 1) GTKGL_SO="gauche-gtkgl.so" GTKGL_LIB="-lgtkgl"; GTKGL_SCM="gtk/gtkgl.scm" PANGOFT2_LIB="-lpangoft2-1.0"; GLGD_SO="gauche-glgd.so" GLGD_LIB="-lglgd"; GLGD_SCM="gtk/glgd.scm" ]) AC_SUBST(GTKGL_SO) AC_SUBST(GTKGL_LIB) AC_SUBST(GTKGL_SCM) AC_SUBST(PANGOFT2_LIB) AC_SUBST(GLGD_SO) AC_SUBST(GLGD_LIB) AC_SUBST(GLGD_SCM) dnl Set up gauche related commands. The commands are set by scanning dnl PATH. You can override them by "GOSH=/my/gosh ./configure" etc. AC_PATH_PROG([GOSH], gosh) AC_PATH_PROG([GAUCHE_CONFIG], gauche-config) AC_PATH_PROG([GAUCHE_PACKAGE], gauche-package) AC_PATH_PROG([GAUCHE_INSTALL], gauche-install) AC_PATH_PROG([GAUCHE_CESCONV], gauche-cesconv) dnl Usually these parameters are set by AC_PROG_CC, but we'd rather use dnl the same one as Gauche has been compiled with. SOEXT=`$GAUCHE_CONFIG --so-suffix` OBJEXT=`$GAUCHE_CONFIG --object-suffix` EXEEXT=`$GAUCHE_CONFIG --executable-suffix` AC_SUBST(SOEXT) AC_SUBST(OBJEXT) AC_SUBST(EXEEXT) ac_default_prefix=`$GAUCHE_CONFIG --prefix` GAUCHE_PKGINCDIR=`$GAUCHE_CONFIG --pkgincdir` GAUCHE_PKGLIBDIR=`$GAUCHE_CONFIG --pkglibdir` GAUCHE_PKGARCHDIR=`$GAUCHE_CONFIG --pkgarchdir` AC_SUBST(GAUCHE_PKGINCDIR) AC_SUBST(GAUCHE_PKGLIBDIR) AC_SUBST(GAUCHE_PKGARCHDIR) # Check for other programs. # Check for libraries AC_PATH_XTRA # Prepare file list. gen_files=`cat src/GDKFILES src/GDKPIXBUFFILES src/GTKFILES src/PANGOFILES` GEN_OBJS="`echo $gen_files | sed 's/\.h/.$(OBJEXT)/g'`" AC_SUBST(GEN_OBJS) GEN_SRCS="`echo $gen_files | sed 's/\.h/.c/g'`" AC_SUBST(GEN_SRCS) GEN_STUBS="`echo $gen_files | sed 's/\.h/.stub/g'`" AC_SUBST(GEN_STUBS) dnl Creating gpd (gauche package description) file GAUCHE_PACKAGE_CONFIGURE_ARGS="`echo ""$ac_configure_args"" | sed 's/[\\""\`\$]/\\\&/g'`" AC_MSG_NOTICE([creating ${PACKAGE_NAME}.gpd]) $GAUCHE_PACKAGE make-gpd "$PACKAGE_NAME" \ -version "$PACKAGE_VERSION" \ -configure "./configure $GAUCHE_PACKAGE_CONFIGURE_ARGS" # Output echo $PACKAGE_VERSION > VERSION AC_OUTPUT(Makefile src/Makefile lib/Makefile gtkgl/Makefile glgd/Makefile) gauche-gtk-0.6+git20160927/examples/000077500000000000000000000000001300401456300166225ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/examples/error-dialog.scm000066400000000000000000000027671300401456300217300ustar00rootroot00000000000000;; sample to use gtk.error-dialog (use gtk) (use gtk.error-dialog) (define *error-count* 0) (define (main args) (gtk-init args) (let ((w (gtk-window-new GTK_WINDOW_TOPLEVEL)) (b (gtk-button-new-with-label "don't press me"))) (g-signal-connect w "destroy" (lambda _ (gtk-main-quit))) (gtk-container-add w b) (g-signal-connect b "clicked" (lambda _ (inc! *error-count*) (case *error-count* ((1) (error "I said not to press me.")) ((2) (error "Stop pressing me, please.")) ((3) (error "What do you want? No white rabbit will come out!")) ((4) (error "OK, You are so bored. But I can offer nothing to you. I'm just a small script with lots of parenthesis.")) ((5) (error "You gotta do something more constructive. How about start reading SICP?")) ((6) (error "SICP is \"Structure and Intepretation of Computer Programs.\" The book is published from MIT Press, but also on-line at http://mitpress.mit.edu/sicp/full-text/book/book.html")) ((7) (error "If you keep doing this, I assure you will keep making errors. You're warned.")) (else (errorf "You made ~a errors." *error-count*)))) ) (gtk-widget-show-all w) (gtk-scheme-enable-error-dialog w)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gdk-animation.scm000066400000000000000000000035121300401456300220510ustar00rootroot00000000000000;; ;; Somebody asked me a sample of doing simple animation in Gauche-gtk, ;; and I hacked this up. If you know better way, let me know. ;; Public domain -- use this as you like. [SK] ;; $Id: gdk-animation.scm,v 1.3 2007/01/13 01:36:29 maruska Exp $ ;; (use math.const) (use gtk) (define *angle* 0) (define (draw drawable fg bg) ;; clear (gdk-draw-rectangle drawable bg #t 0 0 100 100) ;; draw line (let ((x (inexact->exact (round (+ 50 (* (cos *angle*) 50))))) (y (inexact->exact (round (+ 50 (* (sin *angle*) 50)))))) (gdk-draw-line drawable fg 50 50 x y) #t)) (define (main args) (gtk-init args) (let1 w (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect w "destroy" (lambda _ (gtk-main-quit))) (let* ((area (gtk-drawing-area-new)) (drawable #f) ;; initialized by realize callback (fg-gc #f) ;; initialized by realize callback (bg-gc #f) ;; initialized by realize callback ) (gtk-widget-set-size-request area 100 100) (gtk-container-add w area) (g-signal-connect area "realize" (lambda _ (set! drawable (ref area 'window)) (set! fg-gc (gdk-gc-new drawable)) (set! bg-gc (gdk-gc-new drawable)) (gdk-gc-set-foreground bg-gc (ref (ref (ref area 'style) 'bg) 0)) )) (g-signal-connect area "expose_event" (lambda (w event) (draw drawable fg-gc bg-gc))) (gtk-timeout-add 10 (lambda () (inc! *angle* (* pi 0.02)) (when drawable (draw drawable fg-gc bg-gc)))) (gtk-widget-show area) ) (gtk-widget-show w)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/glgd/000077500000000000000000000000001300401456300175375ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/examples/glgd/class.scm000066400000000000000000000461151300401456300213570ustar00rootroot00000000000000;; ;; OpenGL Graph Display demo of a class hierarchy. ;; This program is in the public domain. ;; ;; Shawn Taras ;; $Id: class.scm,v 1.19 2007/01/13 01:36:30 maruska Exp $ ;; (use math.const) (use gauche.charconv) (use gtk) (use gtk.gtkgl) (use gtk.glgd) (use gl) (define *attr-link* 0) (define *attr-link-field* 1) (define *attr-src-node-field* 2) (define *attr-dst-node-field* 3) (define *graph* (glgd-graph-create)) (define *menu-bg* #f) (define *dialog* #f) (define *label* #f) ;; Menu callback routines ;; ---------------------- (define (menu-cb-frame-all event . _) (glgd-graph-frame *graph*) #t) (define (menu-cb-expand-all event . _) (glgd-graph-attribute-set *graph* *attr-link-field*) (glgd-graph-attribute-set *graph* *attr-src-node-field*) (glgd-graph-attribute-set *graph* *attr-dst-node-field*) (glgd-graph-auto-organize *graph* 0.0 0.0) #t) (define (menu-cb-collapse-all event . _) (glgd-graph-attribute-reset *graph* *attr-link-field*) (glgd-graph-attribute-reset *graph* *attr-src-node-field*) (glgd-graph-attribute-reset *graph* *attr-dst-node-field*) (glgd-graph-auto-organize *graph* 0.0 0.0) #t) ;; Dialog utility routines ;; ----------------------- (define (show-dialog dialog label txt) (gtk-label-set-text label txt) (gtk-window-set-position dialog GTK_WIN_POS_MOUSE) (gtk-widget-show dialog) #t) ;; GLGDGRAPH_FN_MOUSE_HOVER callback ;; --------------------------------- (define (mouse-hover-callback graph node link event) (glgd-graph-node-list-flag graph GLGDNODE_FLAG_HILITE GLGD_FLAGOP_CLEAR) (if (= (glgd-graph-link-index graph link) -1) (if (>= (glgd-node-id-get node) -1) (glgd-node-flags-set node GLGDNODE_FLAG_HILITE GLGD_FLAGOP_SET))) #t) ;; GLGDGRAPH_FN_MOUSE_LEFT callback ;; -------------------------------- (define (mouse-left-callback graph node link event) (if (= (ref event 'type) GDK_BUTTON_PRESS) (case (glgd-node-id-get node) ((0) (glgd-graph-attribute-toggle graph *attr-link-field*) (glgd-graph-auto-organize graph 0.0 0.0)) ((1) (show-dialog *dialog* *label* #`"Flags: ???")) ((2) (show-dialog *dialog* *label* #`"Attributes: ???")) ((3) (glgd-graph-attribute-toggle graph *attr-src-node-field*) (glgd-graph-auto-organize graph 0.0 0.0)) ((4) (glgd-graph-attribute-toggle graph *attr-dst-node-field*) (glgd-graph-auto-organize graph 0.0 0.0)) ((5) (show-dialog *dialog* *label* #`"Next Link: ???")) ((6) (show-dialog *dialog* *label* #`"Previous Link: ???")) ((7) (show-dialog *dialog* *label* #`"Flags: ???")) ((8) (show-dialog *dialog* *label* #`"Label: ???")) ((9) (show-dialog *dialog* *label* #`"Node ID: ,(glgd-node-id-get node)")) ((10) (show-dialog *dialog* *label* #`"Position: ???")) ((11) (show-dialog *dialog* *label* #`"Color: ???")) ((12) (show-dialog *dialog* *label* #`"Data: ???")) ((13) (show-dialog *dialog* *label* #`"Next Node: ???")) ((14) (show-dialog *dialog* *label* #`"Previous Node: ???")) ((15) (show-dialog *dialog* *label* #`"Flags: ???")) ((16) (show-dialog *dialog* *label* #`"Label: ???")) ((17) (show-dialog *dialog* *label* #`"Node ID: ,(glgd-node-id-get node)")) ((18) (show-dialog *dialog* *label* #`"Position: ???")) ((19) (show-dialog *dialog* *label* #`"Color: ???")) ((20) (show-dialog *dialog* *label* #`"Data: ???")) ((21) (show-dialog *dialog* *label* #`"Next Node: ???")) ((22) (show-dialog *dialog* *label* #`"Previous Node: ???")))) (if (= (ref event 'type) GDK_BUTTON_RELEASE) (gtk-widget-hide *dialog*)) #t) ;; GLGDGRAPH_FN_MOUSE_RIGHT callback ;; -------------------------------- (define (mouse-right-callback graph node link event) (if (= (glgd-graph-link-index graph link) -1) (gtk-menu-popup *menu-bg* #f #f #f (ref event 'button) (ref event 'time))) #t) ;; GLGDGRAPH_FN_KEY callback ;; ------------------------- (define (key-callback graph node link event) (let1 kv (ref event 'keyval) (cond ((= kv GDK_KEY_Escape) (gtk-main-quit)))) #t) (define (draw widget . _) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (glgd-graph-draw *graph*) (if (gdk-gl-drawable-is-double-buffered gldrawable) (gdk-gl-drawable-swap-buffers gldrawable) (gl-flush)) (gdk-gl-drawable-gl-end gldrawable)) #t)) ;; new window size or exposure (define (reshape widget . _) (let* ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget)) (wsize (ref widget 'allocation)) (h (/ (ref wsize 'height) (ref wsize 'width)))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height)) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** #t) (glgd-graph-reshape *graph*)) (define (init widget) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-light GL_LIGHT0 GL_POSITION '#f32(5.0 5.0 10.0 0.0)) (gl-enable GL_CULL_FACE) (gl-enable GL_LIGHTING) (gl-enable GL_LIGHT0) (gl-enable GL_DEPTH_TEST) (gl-enable GL_NORMALIZE) (print) (print #`"GL_RENDERER = ,(gl-get-string GL_RENDERER)") (print #`"GL_VERSION = ,(gl-get-string GL_VERSION)") (print #`"GL_VENDOR = ,(gl-get-string GL_VENDOR)") (print #`"GL_EXTENSIONS = ,(gl-get-string GL_EXTENSIONS)") (print) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** )) ;; ========================================================================= ;; create a graph representing the and class hierarchy ;; ========================================================================= (define (glgd-graph-build-class graph) (glgd-graph-init graph) (let* ((link (glgd-node-create)) (flags (glgd-node-create)) (attributes (glgd-node-create)) (src-node (glgd-node-create)) (dst-node (glgd-node-create)) (next-link (glgd-node-create)) (prev-link (glgd-node-create)) (src-node-flags (glgd-node-create)) (src-node-label (glgd-node-create)) (src-node-id (glgd-node-create)) (src-node-pos (glgd-node-create)) (src-node-col (glgd-node-create)) (src-node-data (glgd-node-create)) (src-node-next (glgd-node-create)) (src-node-prev (glgd-node-create)) (dst-node-flags (glgd-node-create)) (dst-node-label (glgd-node-create)) (dst-node-id (glgd-node-create)) (dst-node-pos (glgd-node-create)) (dst-node-col (glgd-node-create)) (dst-node-data (glgd-node-create)) (dst-node-next (glgd-node-create)) (dst-node-prev (glgd-node-create))) (glgd-node-info-set link (ces-convert "Link (\u03a0\u03b1\u03bd\u8a9eFT2)" #f "utf8") 0) (glgd-node-attribute-set link *attr-link*) (glgd-node-info-set flags "flags" 1) (glgd-node-attribute-set flags *attr-link-field*) (glgd-node-info-set attributes "attributes" 2) (glgd-node-attribute-set attributes *attr-link-field*) (glgd-node-info-set src-node "src" 3) (glgd-node-attribute-set src-node *attr-link-field*) (glgd-node-info-set dst-node "dst" 4) (glgd-node-attribute-set dst-node *attr-link-field*) (glgd-node-info-set next-link "next" 5) (glgd-node-attribute-set next-link *attr-link-field*) (glgd-node-info-set prev-link "prev" 6) (glgd-node-attribute-set prev-link *attr-link-field*) (glgd-node-info-set src-node-flags "flags" 7) (glgd-node-attribute-set src-node-flags *attr-src-node-field*) (glgd-node-info-set src-node-label "label" 8) (glgd-node-attribute-set src-node-label *attr-src-node-field*) (glgd-node-info-set src-node-id "id" 9) (glgd-node-attribute-set src-node-id *attr-src-node-field*) (glgd-node-info-set src-node-pos "pos" 10) (glgd-node-attribute-set src-node-pos *attr-src-node-field*) (glgd-node-info-set src-node-col "col" 11) (glgd-node-attribute-set src-node-col *attr-src-node-field*) (glgd-node-info-set src-node-data "data" 12) (glgd-node-attribute-set src-node-data *attr-src-node-field*) (glgd-node-info-set src-node-next "next" 13) (glgd-node-attribute-set src-node-next *attr-src-node-field*) (glgd-node-info-set src-node-prev "prev" 14) (glgd-node-attribute-set src-node-prev *attr-src-node-field*) (glgd-node-info-set dst-node-flags "flags" 15) (glgd-node-attribute-set dst-node-flags *attr-dst-node-field*) (glgd-node-info-set dst-node-label "label" 16) (glgd-node-attribute-set dst-node-label *attr-dst-node-field*) (glgd-node-info-set dst-node-id "id" 17) (glgd-node-attribute-set dst-node-id *attr-dst-node-field*) (glgd-node-info-set dst-node-pos "pos" 18) (glgd-node-attribute-set dst-node-pos *attr-dst-node-field*) (glgd-node-info-set dst-node-col "col" 19) (glgd-node-attribute-set dst-node-col *attr-dst-node-field*) (glgd-node-info-set dst-node-data "data" 20) (glgd-node-attribute-set dst-node-data *attr-dst-node-field*) (glgd-node-info-set dst-node-next "next" 21) (glgd-node-attribute-set dst-node-next *attr-dst-node-field*) (glgd-node-info-set dst-node-prev "prev" 22) (glgd-node-attribute-set dst-node-prev *attr-dst-node-field*) (glgd-node-color-set flags 0 0 0.7 1) (glgd-node-color-set attributes 0 0 0.7 1) (glgd-node-color-set src-node 0 0 0.7 1) (glgd-node-color-set dst-node 0 0 0.7 1) (glgd-node-color-set next-link 0 0 0.7 1) (glgd-node-color-set prev-link 0 0 0.7 1) (glgd-node-color-set src-node-flags 0.7 0 0.2 1) (glgd-node-color-set src-node-label 0.7 0 0.2 1) (glgd-node-color-set src-node-id 0.7 0 0.2 1) (glgd-node-color-set src-node-pos 0.7 0 0.2 1) (glgd-node-color-set src-node-col 0.7 0 0.2 1) (glgd-node-color-set src-node-data 0.7 0 0.2 1) (glgd-node-color-set src-node-next 0.7 0 0.2 1) (glgd-node-color-set src-node-prev 0.7 0 0.2 1) (glgd-node-color-set dst-node-flags 0.7 0 0.2 1) (glgd-node-color-set dst-node-label 0.7 0 0.2 1) (glgd-node-color-set dst-node-id 0.7 0 0.2 1) (glgd-node-color-set dst-node-pos 0.7 0 0.2 1) (glgd-node-color-set dst-node-col 0.7 0 0.2 1) (glgd-node-color-set dst-node-data 0.7 0 0.2 1) (glgd-node-color-set dst-node-next 0.7 0 0.2 1) (glgd-node-color-set dst-node-prev 0.7 0 0.2 1) (glgd-graph-node-add graph link) (glgd-graph-node-add graph flags) (glgd-graph-node-add graph attributes) (glgd-graph-node-add graph src-node) (glgd-graph-node-add graph dst-node) (glgd-graph-node-add graph next-link) (glgd-graph-node-add graph prev-link) (glgd-graph-node-add graph src-node-flags) (glgd-graph-node-add graph src-node-label) (glgd-graph-node-add graph src-node-id) (glgd-graph-node-add graph src-node-pos) (glgd-graph-node-add graph src-node-col) (glgd-graph-node-add graph src-node-data) (glgd-graph-node-add graph src-node-next) (glgd-graph-node-add graph src-node-prev) (glgd-graph-node-add graph dst-node-flags) (glgd-graph-node-add graph dst-node-label) (glgd-graph-node-add graph dst-node-id) (glgd-graph-node-add graph dst-node-pos) (glgd-graph-node-add graph dst-node-col) (glgd-graph-node-add graph dst-node-data) (glgd-graph-node-add graph dst-node-next) (glgd-graph-node-add graph dst-node-prev) (let* ((list (glgd-link-list-create)) (l2f (glgd-link-create)) (l2a (glgd-link-create)) (l2sn (glgd-link-create)) (l2dn (glgd-link-create)) (l2nl(glgd-link-create)) (l2pl (glgd-link-create)) (sn2f (glgd-link-create)) (sn2l (glgd-link-create)) (sn2i (glgd-link-create)) (sn2pos (glgd-link-create)) (sn2c (glgd-link-create)) (sn2d (glgd-link-create)) (sn2n (glgd-link-create)) (sn2p (glgd-link-create)) (dn2f (glgd-link-create)) (dn2l (glgd-link-create)) (dn2i (glgd-link-create)) (dn2pos (glgd-link-create)) (dn2c (glgd-link-create)) (dn2d (glgd-link-create)) (dn2n (glgd-link-create)) (dn2p (glgd-link-create))) (glgd-link-set l2f link flags) (glgd-link-set l2a link attributes) (glgd-link-set l2sn link src-node) (glgd-link-set l2dn link dst-node) (glgd-link-set l2nl link next-link) (glgd-link-set l2pl link prev-link) (glgd-link-set sn2f src-node src-node-flags) (glgd-link-set sn2l src-node src-node-label) (glgd-link-set sn2i src-node src-node-id) (glgd-link-set sn2pos src-node src-node-pos) (glgd-link-set sn2c src-node src-node-col) (glgd-link-set sn2d src-node src-node-data) (glgd-link-set sn2n src-node src-node-next) (glgd-link-set sn2p src-node src-node-prev) (glgd-link-set dn2f dst-node dst-node-flags) (glgd-link-set dn2l dst-node dst-node-label) (glgd-link-set dn2i dst-node dst-node-id) (glgd-link-set dn2pos dst-node dst-node-pos) (glgd-link-set dn2c dst-node dst-node-col) (glgd-link-set dn2d dst-node dst-node-data) (glgd-link-set dn2n dst-node dst-node-next) (glgd-link-set dn2p dst-node dst-node-prev) (glgd-graph-link-add graph list l2pl) (glgd-graph-link-add graph list l2nl) (glgd-graph-link-add graph list l2dn) (glgd-graph-link-add graph list l2sn) (glgd-graph-link-add graph list l2a) (glgd-graph-link-add graph list l2f) (glgd-graph-link-add graph list sn2p) (glgd-graph-link-add graph list sn2n) (glgd-graph-link-add graph list sn2d) (glgd-graph-link-add graph list sn2c) (glgd-graph-link-add graph list sn2pos) (glgd-graph-link-add graph list sn2i) (glgd-graph-link-add graph list sn2l) (glgd-graph-link-add graph list sn2f) (glgd-graph-link-add graph list dn2p) (glgd-graph-link-add graph list dn2n) (glgd-graph-link-add graph list dn2d) (glgd-graph-link-add graph list dn2c) (glgd-graph-link-add graph list dn2pos) (glgd-graph-link-add graph list dn2i) (glgd-graph-link-add graph list dn2l) (glgd-graph-link-add graph list dn2f) (glgd-graph-link-list-add graph list))) (glgd-graph-attribute-set graph *attr-link*) (glgd-graph-attribute-set graph *attr-link-field*) (glgd-graph-auto-organize graph 0.0 0.0) (glgd-graph-link-list-dump graph) (glgd-graph-callback-set graph GLGDGRAPH_FN_KEY key-callback) (glgd-graph-callback-set graph GLGDGRAPH_FN_MOUSE_HOVER mouse-hover-callback) (glgd-graph-callback-set graph GLGDGRAPH_FN_MOUSE_LEFT mouse-left-callback) (glgd-graph-callback-set graph GLGDGRAPH_FN_MOUSE_RIGHT mouse-right-callback) #t) (define (main args) (gtk-init args) (unless (gdk-gl-query-extension) (error "*** OpenGL is not supported.")) ;; ;; Configure OpenGL-capable visual. ;; (let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH GDK_GL_MODE_DOUBLE)) (begin (warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n") (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH))) (error "*** No appropriate OpenGL-capable visual found.") ) ;; ;; Top-level window. ;; (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Class Graph Demo") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) ;; ;; Drawing area for drawing OpenGL scene. ;; (let1 drawing-area (gtk-drawing-area-new) (gtk-widget-set-size-request drawing-area 640 480) ;; Set OpenGL-capability to the widget. (gtk-widget-set-gl-capability drawing-area glconfig #f #t GDK_GL_RGBA_TYPE) (gtk-box-pack-start vbox drawing-area #t #t 0) (gtk-widget-set-events drawing-area (logior GDK_EXPOSURE_MASK GDK_VISIBILITY_NOTIFY_MASK)) (g-signal-connect drawing-area "realize" init) (g-signal-connect drawing-area "configure_event" reshape) (g-signal-connect drawing-area "expose_event" draw) (glgd-graph-build-class *graph*) (glgd-graph-connect *graph* drawing-area) (gtk-widget-show drawing-area)) ;; ;; Simple quit button. ;; (let1 button (gtk-button-new-with-label "Quit") (gtk-box-pack-start vbox button #f #f 0) (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-widget-show button)) );vbox ;; Initialize dialogs ;; ------------------ (set! *dialog* (gtk-window-new GTK_WINDOW_POPUP)) (gtk-window-set-decorated *dialog* #f) (gtk-widget-set-size-request *dialog* 112 32) (gtk-container-set-border-width *dialog* 2) (let1 frame (gtk-frame-new #f) (gtk-container-add *dialog* frame) (gtk-frame-set-shadow-type frame GTK_SHADOW_ETCHED_OUT) (gtk-widget-show frame) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add frame vbox) (gtk-widget-show vbox) (set! *label* (gtk-label-new "label")) (gtk-box-pack-start vbox *label* #t #t 0) (gtk-widget-show *label*))) ;; Initialize pop-up menus ;; ----------------------- (set! *menu-bg* (gtk-menu-new)) (let* ((str #`"Frame All") (menu-item (gtk-menu-item-new-with-label str))) (gtk-menu-shell-append *menu-bg* menu-item) (g-signal-connect menu-item "activate" menu-cb-frame-all) (gtk-widget-show menu-item)) (let1 separator (gtk-separator-menu-item-new) (gtk-menu-shell-append *menu-bg* separator) (gtk-widget-show separator)) (let* ((str #`"Expand All") (menu-item (gtk-menu-item-new-with-label str))) (gtk-menu-shell-append *menu-bg* menu-item) (g-signal-connect menu-item "activate" menu-cb-expand-all) (gtk-widget-show menu-item)) (let* ((str #`"Collapse All") (menu-item (gtk-menu-item-new-with-label str))) (gtk-menu-shell-append *menu-bg* menu-item) (g-signal-connect menu-item "activate" menu-cb-collapse-all) (gtk-widget-show menu-item)) ;; Show the window ;; --------------- (gtk-widget-show window) ) (gtk-main) (glgd-graph-fini *graph*) 0)) gauche-gtk-0.6+git20160927/examples/glgd/run000077500000000000000000000000701300401456300202660ustar00rootroot00000000000000#!/bin/sh gosh -I../../src -I../../lib -I../../glgd $@ gauche-gtk-0.6+git20160927/examples/glgd/simple.scm000066400000000000000000000223001300401456300215310ustar00rootroot00000000000000;; ;; Simple OpenGL Graph Display. This program is in the public domain. ;; ;; Shawn Taras ;; $Id: simple.scm,v 1.21 2007/01/13 01:36:30 maruska Exp $ (use math.const) (use math.mt-random) (use gtk) (use gtk.gtkgl) (use gtk.glgd) (use gl) (define *attr-geometry* 0) (define *attr-skeleton* 1) (define *attr-current* GLGD_ATTR_FORCEVISIBLE) (define *graph* (glgd-graph-create)) (define *mt* (make )) ;; GLGDGRAPH_FN_MOUSE_LEFT callback ;; -------------------------------- (define (mouse-left-callback graph node link event) (when (= (ref event 'type) GDK_BUTTON_PRESS) (if (= *attr-current* GLGD_ATTR_FORCEVISIBLE) (set! *attr-current* *attr-geometry*) (set! *attr-current* (+ *attr-current* 1))) (if (> *attr-current* *attr-skeleton*) (set! *attr-current* GLGD_ATTR_FORCEVISIBLE)) (glgd-graph-attribute-clear graph) (glgd-graph-attribute-set graph *attr-current*) (glgd-graph-auto-organize graph 0.0 0.0) (print #`"*attr-current* now ,*attr-current*") (print #`"left mouse click on node ,(glgd-node-id-get node)") (print #`"left mouse click on link ,(glgd-graph-link-index graph link)")) #t) ;; GLGDGRAPH_FN_KEY callback ;; ------------------------- (define (key-callback graph node link event) (let1 kv (ref event 'keyval) (cond ((= kv GDK_KEY_Escape) (gtk-main-quit)))) #t) ;; GLGDGRAPH_FN_PRERENDER callback ;; ------------------------------- (define (pre-draw-callback node) (glgd-node-color-set node (mt-random-real *mt*) (mt-random-real *mt*) (mt-random-real *mt*) 1.0) #t) (define (draw widget . _) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (glgd-graph-draw *graph*) (if (gdk-gl-drawable-is-double-buffered gldrawable) (gdk-gl-drawable-swap-buffers gldrawable) (gl-flush)) (gdk-gl-drawable-gl-end gldrawable)) #t)) ;; new window size or exposure (define (reshape widget . _) (let* ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget)) (wsize (ref widget 'allocation)) (h (/ (ref wsize 'height) (ref wsize 'width)))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height)) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** #t) (glgd-graph-reshape *graph*)) (define (init widget) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-light GL_LIGHT0 GL_POSITION '#f32(5.0 5.0 10.0 0.0)) (gl-enable GL_CULL_FACE) (gl-enable GL_LIGHTING) (gl-enable GL_LIGHT0) (gl-enable GL_DEPTH_TEST) (gl-enable GL_NORMALIZE) (print) (print #`"GL_RENDERER = ,(gl-get-string GL_RENDERER)") (print #`"GL_VERSION = ,(gl-get-string GL_VERSION)") (print #`"GL_VENDOR = ,(gl-get-string GL_VENDOR)") (print #`"GL_EXTENSIONS = ,(gl-get-string GL_EXTENSIONS)") (print) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** )) ;; exit upon ESC (define (key widget event) (let ((kv (ref event 'keyval)) (q (lambda () (gtk-widget-queue-draw widget)))) (cond ((= kv GDK_KEY_Escape) (gtk-main-quit)))) #t) ;; create a simple graph (define (glgd-graph-build-simple graph) (glgd-graph-init graph) (let* ((model (glgd-node-create)) (geometry (glgd-node-create)) (torso (glgd-node-create)) (arms (glgd-node-create)) (legs (glgd-node-create)) (skeleton (glgd-node-create)) (hip (glgd-node-create)) (thighLeft (glgd-node-create)) (thighRight (glgd-node-create))) (glgd-node-info-set model "model" 0) (glgd-node-attribute-set model *attr-geometry*) (glgd-node-info-set geometry "geometry" 1) (glgd-node-attribute-set geometry *attr-geometry*) (glgd-node-info-set skeleton "skeleton" 2) (glgd-node-attribute-set skeleton *attr-skeleton*) (glgd-node-info-set torso "torso" 3) (glgd-node-attribute-set torso *attr-geometry*) (glgd-node-info-set arms "arms" 4) (glgd-node-attribute-set arms *attr-geometry*) (glgd-node-info-set legs "legs" 5) (glgd-node-attribute-set legs *attr-geometry*) (glgd-node-info-set hip "hip" 6) (glgd-node-attribute-set hip *attr-skeleton*) (glgd-node-info-set thighLeft "thighLeft" 7) (glgd-node-attribute-set thighLeft *attr-skeleton*) (glgd-node-info-set thighRight "thighRight" 8) (glgd-node-attribute-set thighRight *attr-skeleton*) (glgd-graph-node-add graph model) (glgd-graph-node-add graph geometry) (glgd-graph-node-add graph skeleton) (glgd-graph-node-add graph torso) (glgd-graph-node-add graph arms) (glgd-graph-node-add graph legs) (glgd-graph-node-add graph hip) (glgd-graph-node-add graph thighLeft) (glgd-graph-node-add graph thighRight) (let* ((list (glgd-link-list-create)) (m2g (glgd-link-create)) (g2t (glgd-link-create)) (g2a (glgd-link-create)) (g2l (glgd-link-create)) (m2s (glgd-link-create)) (s2h (glgd-link-create)) (h2tl (glgd-link-create)) (h2tr (glgd-link-create)) (tr2h (glgd-link-create)) (tr2s (glgd-link-create))) (glgd-link-set m2g model geometry) (glgd-link-set g2t geometry torso) (glgd-link-set g2a geometry arms) (glgd-link-set g2l geometry legs) (glgd-link-set m2s model skeleton) (glgd-link-set s2h skeleton hip) (glgd-link-set h2tl hip thighLeft) (glgd-link-set h2tr hip thighRight) (glgd-link-set tr2h thighRight hip) (glgd-link-set tr2s thighRight skeleton) (glgd-graph-link-add graph list m2g) (glgd-graph-link-add graph list m2s) (glgd-graph-link-add graph list g2t) (glgd-graph-link-add graph list g2a) (glgd-graph-link-add graph list g2l) (glgd-graph-link-add graph list s2h) (glgd-graph-link-add graph list h2tl) (glgd-graph-link-add graph list h2tr) (glgd-graph-link-add graph list tr2h) (glgd-graph-link-add graph list tr2s) (glgd-graph-link-list-add graph list))) (glgd-graph-attribute-set graph *attr-current*) (glgd-graph-auto-organize graph 0.0 0.0) (glgd-graph-link-list-dump graph) (glgd-graph-callback-set graph GLGDGRAPH_FN_PRERENDER pre-draw-callback) (glgd-graph-callback-set graph GLGDGRAPH_FN_KEY key-callback) (glgd-graph-callback-set graph GLGDGRAPH_FN_MOUSE_LEFT mouse-left-callback) #t) (define (main args) (gtk-init args) (glgd-verbosity 1) (unless (gdk-gl-query-extension) (error "*** OpenGL is not supported.")) ;; ;; Configure OpenGL-capable visual. ;; (let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH GDK_GL_MODE_DOUBLE)) (begin (warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n") (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH))) (error "*** No appropriate OpenGL-capable visual found.") ) ;; ;; Top-level window. ;; (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Simple Graph Demo") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) ;; ;; Drawing area for drawing OpenGL scene. ;; (let1 drawing-area (gtk-drawing-area-new) (gtk-widget-set-size-request drawing-area 640 480) ;; Set OpenGL-capability to the widget. (gtk-widget-set-gl-capability drawing-area glconfig #f #t GDK_GL_RGBA_TYPE) (gtk-box-pack-start vbox drawing-area #t #t 0) (gtk-widget-set-events drawing-area (logior GDK_EXPOSURE_MASK GDK_VISIBILITY_NOTIFY_MASK)) (g-signal-connect drawing-area "realize" init) (g-signal-connect drawing-area "configure_event" reshape) (g-signal-connect drawing-area "expose_event" draw) (glgd-graph-build-simple *graph*) (glgd-graph-connect *graph* drawing-area) (gtk-widget-show drawing-area)) ;; ;; Simple quit button. ;; (let1 button (gtk-button-new-with-label "Quit") (gtk-box-pack-start vbox button #f #f 0) (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-widget-show button)) );vbox (gtk-widget-show window) ) (gtk-main) (glgd-graph-fini *graph*) 0)) gauche-gtk-0.6+git20160927/examples/glgd/simple2.scm000066400000000000000000000104301300401456300216140ustar00rootroot00000000000000;; ;; like "simple", but using higher-level widget. ;; $Id: simple2.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ ;; (use gtk) (use gtk.gtkgl) (use gtk.glgd) (define *attr-geometry* 0) (define *attr-skeleton* 1) (define *attr-current* GLGD_ATTR_FORCEVISIBLE) (define (main args) (gtk-init args) (unless (gdk-gl-query-extension) (error "*** OpenGL is not supported.")) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "objview") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) ;; ;; Drawing area for drawing OpenGL scene. ;; (let1 graph-area (make ) (gtk-widget-set-size-request graph-area 640 480) (gtk-box-pack-start vbox graph-area #t #t 0) (graph-build-simple (ref graph-area 'graph)) (gtk-widget-show graph-area)) ;; ;; Simple quit button. ;; (let1 button (gtk-button-new-with-label "Quit") (gtk-box-pack-start vbox button #f #f 0) (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-widget-show button)) ) (gtk-widget-show window) (gtk-main) 0)) ;; create a simple graph (define (graph-build-simple graph) (glgd-graph-init graph) (let* ((model (glgd-node-create)) (geometry (glgd-node-create)) (torso (glgd-node-create)) (arms (glgd-node-create)) (legs (glgd-node-create)) (skeleton (glgd-node-create)) (hip (glgd-node-create)) (thighLeft (glgd-node-create)) (thighRight (glgd-node-create))) (glgd-node-info-set model "model" 0) (glgd-node-attribute-set model *attr-geometry*) (glgd-node-info-set geometry "geometry" 1) (glgd-node-attribute-set geometry *attr-geometry*) (glgd-node-info-set skeleton "skeleton" 2) (glgd-node-attribute-set skeleton *attr-skeleton*) (glgd-node-info-set torso "torso" 3) (glgd-node-attribute-set torso *attr-geometry*) (glgd-node-info-set arms "arms" 4) (glgd-node-attribute-set arms *attr-geometry*) (glgd-node-info-set legs "legs" 5) (glgd-node-attribute-set legs *attr-geometry*) (glgd-node-info-set hip "hip" 6) (glgd-node-attribute-set hip *attr-skeleton*) (glgd-node-info-set thighLeft "thighLeft" 7) (glgd-node-attribute-set thighLeft *attr-skeleton*) (glgd-node-info-set thighRight "thighRight" 8) (glgd-node-attribute-set thighRight *attr-skeleton*) (glgd-graph-node-add graph model) (glgd-graph-node-add graph geometry) (glgd-graph-node-add graph skeleton) (glgd-graph-node-add graph torso) (glgd-graph-node-add graph arms) (glgd-graph-node-add graph legs) (glgd-graph-node-add graph hip) (glgd-graph-node-add graph thighLeft) (glgd-graph-node-add graph thighRight) (let* ((list (glgd-link-list-create)) (m2g (glgd-link-create)) (g2t (glgd-link-create)) (g2a (glgd-link-create)) (g2l (glgd-link-create)) (m2s (glgd-link-create)) (s2h (glgd-link-create)) (h2tl (glgd-link-create)) (h2tr (glgd-link-create)) (tr2h (glgd-link-create)) (tr2s (glgd-link-create))) (glgd-link-set m2g model geometry) (glgd-link-set g2t geometry torso) (glgd-link-set g2a geometry arms) (glgd-link-set g2l geometry legs) (glgd-link-set m2s model skeleton) (glgd-link-set s2h skeleton hip) (glgd-link-set h2tl hip thighLeft) (glgd-link-set h2tr hip thighRight) (glgd-link-set tr2h thighRight hip) (glgd-link-set tr2s thighRight skeleton) (glgd-graph-link-add graph list m2g) (glgd-graph-link-add graph list m2s) (glgd-graph-link-add graph list g2t) (glgd-graph-link-add graph list g2a) (glgd-graph-link-add graph list g2l) (glgd-graph-link-add graph list s2h) (glgd-graph-link-add graph list h2tl) (glgd-graph-link-add graph list h2tr) (glgd-graph-link-add graph list tr2h) (glgd-graph-link-add graph list tr2s) (glgd-graph-link-list-add graph list))) (glgd-graph-attribute-set graph *attr-current*) (glgd-graph-auto-organize graph 0.0 0.0) (glgd-graph-link-list-dump graph) #t) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/000077500000000000000000000000001300401456300212505ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/examples/gtk-tutorial/COPYING000066400000000000000000000026131300401456300223050ustar00rootroot00000000000000The Scheme programs in this directory are derived from the C code examples in GTK Tutorial, and covered by the same license term. The original copyright notice follows. ------------------------------------------------------------------------ The GTK Tutorial is Copyright (C) 1997 Ian Main. Copyright (C) 1998-2002 Tony Gale. Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. Permission is granted to copy and distribute modified versions of this document under the conditions for verbatim copying, provided that this copyright notice is included exactly as in the original, and that the entire resulting derived work is distributed under the terms of a permission notice identical to this one. Permission is granted to copy and distribute translations of this document into another language, under the above conditions for modified versions. If you are intending to incorporate this document into a published work, please contact the maintainer, and we will make an effort to ensure that you have the most up to date information available. There is no guarantee that this document lives up to its intended purpose. This is simply provided as a free resource. As such, the authors and maintainers of the information provided within can not make any guarantee that the information is even accurate. gauche-gtk-0.6+git20160927/examples/gtk-tutorial/README000066400000000000000000000021241300401456300221270ustar00rootroot00000000000000The Scheme scripts in this directory are ported from examples that come with Gtk2. (The original source can be found under the examples directory of Gtk source code). The scripts are named according to the original source, i.e. arrow.scm for arrow.c, etc. Since the original example code comes with Gtk which is LGPL, I assume the ported Scheme code should be also covered by LGPL. A copy of LGPL is included in the directory. I tried to keep the structure of the source, so you can easily compare the C version and the Scheme version to see how APIs are mapped. The most significant difference is callback functions- in Scheme we can use closures, eliminating the need of 'data' argument, and 'g_signal_connect_swapped' mechanism. To run the example script from this directory before installing Gauche-gtk, run it as follows: gosh -I../../src -I../../lib script.scm The following examples are not ported yet, mainly because of lack of needed API. calendar gtkdial rulers selection tictactoe The following examples are not included, since they use deprecated widgets. text tree gauche-gtk-0.6+git20160927/examples/gtk-tutorial/arrow.scm000066400000000000000000000025121300401456300231060ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: arrow.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (create-arrow-button arrow-type shadow-type) (let ((button (gtk-button-new)) (arrow (gtk-arrow-new arrow-type shadow-type))) (gtk-container-add button arrow) (gtk-widget-show button) (gtk-widget-show arrow) button)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Arrow Buttons") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (let1 box (gtk-hbox-new #f 0) (gtk-container-set-border-width box 2) (gtk-container-add window box) (gtk-widget-show box) (let1 button (create-arrow-button GTK_ARROW_UP GTK_SHADOW_IN) (gtk-box-pack-start box button #f #f 3)) (let1 button (create-arrow-button GTK_ARROW_DOWN GTK_SHADOW_OUT) (gtk-box-pack-start box button #f #f 3)) (let1 button (create-arrow-button GTK_ARROW_LEFT GTK_SHADOW_ETCHED_IN) (gtk-box-pack-start box button #f #f 3)) (let1 button (create-arrow-button GTK_ARROW_RIGHT GTK_SHADOW_ETCHED_OUT) (gtk-box-pack-start box button #f #f 3)) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/aspectframe.scm000066400000000000000000000017031300401456300242470ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: aspectframe.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Aspect Frame") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (let1 aspect-frame (gtk-aspect-frame-new "2x1" 0.5 0.5 2 #f) (gtk-container-add window aspect-frame) (gtk-widget-show aspect-frame) ;; Create drawingarea and request it to be 200x200; but the aspect ;; frame forces 2x1 aspect, making it 200x100. (let1 drawing-area (gtk-drawing-area-new) (gtk-widget-set-size-request drawing-area 200 200) (gtk-container-add aspect-frame drawing-area) (gtk-widget-show drawing-area) ) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/base.scm000066400000000000000000000004421300401456300226660ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: base.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-widget-show window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/buttonbox.scm000066400000000000000000000065751300401456300240150ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: buttonbox.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (create-bbox horizontal? title spacing child-w child-h layout) (let ((frame (gtk-frame-new title)) (bbox (if horizontal? (gtk-hbutton-box-new) (gtk-vbutton-box-new)))) (gtk-container-set-border-width bbox 5) (gtk-container-add frame bbox) (gtk-button-box-set-layout bbox layout) (gtk-box-set-spacing bbox spacing) (let1 button (gtk-button-new-from-stock GTK_STOCK_OK) (gtk-container-add bbox button)) (let1 button (gtk-button-new-from-stock GTK_STOCK_CANCEL) (gtk-container-add bbox button)) (let1 button (gtk-button-new-from-stock GTK_STOCK_HELP) (gtk-container-add bbox button)) frame)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Button Boxes") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (let1 main-vbox (gtk-vbox-new #f 0) (gtk-container-add window main-vbox) (let1 frame-horz (gtk-frame-new "Horizontal Button Boxes") (gtk-box-pack-start main-vbox frame-horz #t #t 10) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-set-border-width vbox 10) (gtk-container-add frame-horz vbox) (gtk-box-pack-start vbox (create-bbox #t "Spread (spacing 40)" 40 85 20 GTK_BUTTONBOX_SPREAD) #t #t 0) (gtk-box-pack-start vbox (create-bbox #t "Edge (spacing 30)" 30 85 20 GTK_BUTTONBOX_EDGE) #t #t 5) (gtk-box-pack-start vbox (create-bbox #t "Start (spacing 20)" 20 85 20 GTK_BUTTONBOX_START) #t #t 5) (gtk-box-pack-start vbox (create-bbox #t "End (spacing 10)" 10 85 20 GTK_BUTTONBOX_END) #t #t 5) )) (let1 frame-vert (gtk-frame-new "Vertical Button Boxes") (gtk-box-pack-start main-vbox frame-vert #t #t 10) (let1 hbox (gtk-hbox-new #f 0) (gtk-container-set-border-width hbox 10) (gtk-container-add frame-vert hbox) (gtk-box-pack-start hbox (create-bbox #f "Spread (spacing 5)" 5 85 20 GTK_BUTTONBOX_SPREAD) #t #t 0) (gtk-box-pack-start hbox (create-bbox #f "Edge (spacing 30)" 30 85 20 GTK_BUTTONBOX_EDGE) #t #t 5) (gtk-box-pack-start hbox (create-bbox #f "Start (spacing 20)" 20 85 20 GTK_BUTTONBOX_START) #t #t 5) (gtk-box-pack-start hbox (create-bbox #f "End (spacing 10)" 20 85 20 GTK_BUTTONBOX_END) #t #t 5) )) (gtk-widget-show-all window))) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/buttons.scm000066400000000000000000000023311300401456300234510ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: buttons.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (xpm-label-box xpm-filename label-text) (let ((box (gtk-hbox-new #f 0)) (image (gtk-image-new-from-file xpm-filename)) (label (gtk-label-new label-text))) (gtk-container-set-border-width box 2) (gtk-box-pack-start box image #f #f 3) (gtk-box-pack-start box label #f #f 3) (gtk-widget-show image) (gtk-widget-show label) box)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Pixmap'd Buttons!") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (let1 button (gtk-button-new) (g-signal-connect button "clicked" (lambda _ (format #t "cool button clicked\n"))) (let1 box (xpm-label-box "info.xpm" "cool button") (gtk-widget-show box) (gtk-container-add button box)) (gtk-widget-show button) (gtk-container-add window button)) (gtk-widget-show window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/entry.scm000066400000000000000000000051721300401456300231220ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: entry.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-widget-set-size-request window 200 100) (gtk-window-set-title window "GTK Entry") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (g-signal-connect window "delete_event" (lambda _ (gtk-widget-destroy window))) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) (let1 entry (gtk-entry-new) (gtk-entry-set-max-length entry 50) (g-signal-connect entry "activate" (lambda (entry) (format #t "Entry contents: ~a\n" (gtk-entry-get-text entry)) )) (gtk-entry-set-text entry "hello") (let1 pos (slot-ref entry 'text-length) (gtk-editable-insert-text entry " world" pos)) (gtk-editable-select-region entry 0 (slot-ref entry 'text-length)) (gtk-box-pack-start vbox entry #t #t 0) (gtk-widget-show entry) (let1 hbox (gtk-hbox-new #f 0) (gtk-container-add vbox hbox) (gtk-widget-show hbox) (let1 check (gtk-check-button-new-with-label "Editable") (gtk-box-pack-start hbox check #t #t 0) (g-signal-connect check "toggled" (lambda (check) (gtk-editable-set-editable entry (not (zero? (slot-ref check 'active)))))) (gtk-toggle-button-set-active check #t) (gtk-widget-show check)) (let1 check (gtk-check-button-new-with-label "Visible") (gtk-box-pack-start hbox check #t #t 0) (g-signal-connect check "toggled" (lambda (check) (gtk-entry-set-visibility entry (not (zero? (slot-ref check 'active)))))) (gtk-toggle-button-set-active check #t) (gtk-widget-show check)) ) ) (let1 button (gtk-button-new-from-stock GTK_STOCK_CLOSE) (g-signal-connect button "clicked" (lambda _ (gtk-widget-destroy window))) (gtk-box-pack-start vbox button #t #t 0) (gtk-widget-set-flags button GTK_CAN_DEFAULT) (gtk-widget-grab-default button) (gtk-widget-show button)) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/eventbox.scm000066400000000000000000000021231300401456300236040ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: eventbox.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Event Box") (g-signal-connect window "destroy" (lambda _ (exit 0))) (gtk-container-set-border-width window 10) (let1 event-box (gtk-event-box-new) (gtk-container-add window event-box) (gtk-widget-show event-box) (let1 label (gtk-label-new "Click here to quit, quit, quit, quit, quit") (gtk-container-add event-box label) (gtk-widget-show label) (gtk-widget-set-size-request label 110 20) ) (gtk-widget-set-events event-box GDK_BUTTON_PRESS_MASK) (g-signal-connect event-box "button_press_event" (lambda _ (exit 0))) (gtk-widget-realize event-box) (gdk-window-set-cursor (ref event-box 'window) (gdk-cursor-new GDK_HAND1)) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/filesel.scm000066400000000000000000000011451300401456300234000ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: filesel.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 filew (gtk-file-selection-new "File selection") (g-signal-connect filew "destroy" (lambda _ (gtk-main-quit))) (g-signal-connect (slot-ref filew 'ok-button) "clicked" (lambda (w) (format #t "~a\n" (gtk-file-selection-get-filename filew)))) (gtk-file-selection-set-filename filew "penguin.png") (gtk-widget-show filew) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/fixed.scm000066400000000000000000000020361300401456300230540ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: fixed.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Fixed Container") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (let ((fixed (gtk-fixed-new)) (x 50) (y 50)) (gtk-container-add window fixed) (gtk-widget-show fixed) (dotimes (i 3) (let1 button (gtk-button-new-with-label "Press me") (g-signal-connect button "clicked" (lambda (w) (set! x (modulo (+ x 30) 300)) (set! y (modulo (+ y 50) 300)) (gtk-fixed-move fixed w x y))) (gtk-fixed-put fixed button (* (+ i 1) 50) (* (+ i 1) 50)) (gtk-widget-show button))) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/frame.scm000066400000000000000000000014241300401456300230470ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: frame.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Frame Example") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-widget-set-size-request window 300 300) (gtk-container-set-border-width window 10) (let1 frame (gtk-frame-new #f) (gtk-container-add window frame) (gtk-frame-set-label frame "GTK Frame Widget") (gtk-frame-set-label-align frame 1.0 1.0) (gtk-frame-set-shadow-type frame GTK_SHADOW_ETCHED_OUT) (gtk-widget-show frame) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/helloworld.scm000066400000000000000000000017211300401456300241300ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; Difference from C version: Scheme version's signal callback ;; doesn't take extra "user data": you can use closure if you need ;; extra data. With the same reason, there's no 'g-signal-connect-swapped'. ;; ;; $Id: helloworld.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (hello w) (format #t "Hello world (~s)\n" w)) (define (destroy w) (format #t "Destroying ~s\n" w) (gtk-main-quit)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect window "destroy" destroy) (gtk-container-set-border-width window 10) (let1 button (gtk-button-new-with-label "Hello world") (g-signal-connect button "clicked" hello) (g-signal-connect button "clicked" (lambda _ (destroy window))) (gtk-container-add window button) (gtk-widget-show button) (gtk-widget-show window) )) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/helloworld2.scm000066400000000000000000000021371300401456300242140ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: helloworld2.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (callback w button) (format #t "Hello again (~s) - ~s was pressed.\n" w button)) (define (delete-event w event) (gtk-main-quit)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Hello Buttons!") (g-signal-connect window "delete_event" delete-event) (gtk-container-set-border-width window 10) (let ((box1 (gtk-hbox-new #f 0)) (button1 (gtk-button-new-with-label "Button 1")) (button2 (gtk-button-new-with-label "Button 2"))) (gtk-container-add window box1) (g-signal-connect button1 "clicked" (cut callback <> "button 1")) (gtk-box-pack-start box1 button1 #t #t 0) (gtk-widget-show button1) (g-signal-connect button2 "clicked" (cut callback <> "button 2")) (gtk-box-pack-start box1 button2 #t #t 0) (gtk-widget-show button2) (gtk-widget-show box1) (gtk-widget-show window) )) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/info.xpm000066400000000000000000000037671300401456300227460ustar00rootroot00000000000000/* XPM */ static char *openfile[] = { /* width height num_colors chars_per_pixel */ " 20 19 66 2", /* colors */ ".. c None", ".# c #000000", ".a c #dfdfdf", ".b c #7f7f7f", ".c c #006f6f", ".d c #00efef", ".e c #009f9f", ".f c #004040", ".g c #00bfbf", ".h c #ff0000", ".i c #ffffff", ".j c #7f0000", ".k c #007070", ".l c #00ffff", ".m c #00a0a0", ".n c #004f4f", ".o c #00cfcf", ".p c #8f8f8f", ".q c #6f6f6f", ".r c #a0a0a0", ".s c #7f7f00", ".t c #007f7f", ".u c #5f5f5f", ".v c #707070", ".w c #00f0f0", ".x c #009090", ".y c #ffff00", ".z c #0000ff", ".A c #00afaf", ".B c #00d0d0", ".C c #00dfdf", ".D c #005f5f", ".E c #00b0b0", ".F c #001010", ".G c #00c0c0", ".H c #000f0f", ".I c #00007f", ".J c #005050", ".K c #002f2f", ".L c #dfcfcf", ".M c #dfd0d0", ".N c #006060", ".O c #00e0e0", ".P c #00ff00", ".Q c #002020", ".R c #dfc0c0", ".S c #008080", ".T c #001f1f", ".U c #003f3f", ".V c #007f00", ".W c #00000f", ".X c #000010", ".Y c #00001f", ".Z c #000020", ".0 c #00002f", ".1 c #000030", ".2 c #00003f", ".3 c #000040", ".4 c #00004f", ".5 c #000050", ".6 c #00005f", ".7 c #000060", ".8 c #00006f", ".9 c #000070", "#. c #7f7f80", "## c #9f9f9f", /* pixels */ "........................................", "........................................", "........................................", ".......................#.#.#............", ".....................#.......#...#......", "...............................#.#......", ".......#.#.#.................#.#.#......", ".....#.y.i.y.#.#.#.#.#.#.#..............", ".....#.i.y.i.y.i.y.i.y.i.#..............", ".....#.y.i.y.i.y.i.y.i.y.#..............", ".....#.i.y.i.y.#.#.#.#.#.#.#.#.#.#.#....", ".....#.y.i.y.#.s.s.s.s.s.s.s.s.s.#......", ".....#.i.y.#.s.s.s.s.s.s.s.s.s.#........", ".....#.y.#.s.s.s.s.s.s.s.s.s.#..........", ".....#.#.s.s.s.s.s.s.s.s.s.#............", ".....#.#.#.#.#.#.#.#.#.#.#..............", "........................................", "........................................", "........................................" }; gauche-gtk-0.6+git20160927/examples/gtk-tutorial/label.scm000066400000000000000000000067111300401456300230400ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: label.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-window-set-title window "Label") (let1 hbox (gtk-hbox-new #f 5) (let1 vbox (gtk-vbox-new #f 5) (gtk-container-add window hbox) (gtk-box-pack-start hbox vbox #f #f 0) (gtk-container-set-border-width window 5) (let ((frame (gtk-frame-new "Normal Label")) (label (gtk-label-new "This is a Normal label"))) (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) (let ((frame (gtk-frame-new "Multi-line Label")) (label (gtk-label-new "This is a Multi-line label.\nSecond line\nThird line"))) (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) (let ((frame (gtk-frame-new "Left Justified Label")) (label (gtk-label-new "This is a Left-Justified\nMulti-line label.\nThird line"))) (gtk-label-set-justify label GTK_JUSTIFY_LEFT) (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) (let ((frame (gtk-frame-new "Right Justified Label")) (label (gtk-label-new "This is a Right-Justified\nMulti-line label.\nFourth line, (j/k)"))) (gtk-label-set-justify label GTK_JUSTIFY_RIGHT) (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) ) (let1 vbox (gtk-vbox-new #f 5) (gtk-box-pack-start hbox vbox #f #f 0) (let ((frame (gtk-frame-new "Line wrapped label")) (label (gtk-label-new "This is an example of a line-wrapped label. It should not be taking up the entire width allocated to it, but automatically wraps the words to fit. The time has come, for all good men, to come to the aid of their party. The sixth sheik's six sheep's sick.\n It supports multiple paragraphs correctly, and correctly adds many extra spaces. "))) (gtk-label-set-line-wrap label #t) (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) (let ((frame (gtk-frame-new "Filled, wrapped label")) (label (gtk-label-new "This is an example of a line-wrapped, filled label. It should be taking up the entire width allocated to it. Here is a sentence to prove my point. Here is another sentence. Here comes the son, do de do de do.\n This is a new paragraph.\n This is another newer, longer, better paragraph. It is coming to an end, unfortunately."))) (gtk-label-set-justify label GTK_JUSTIFY_FILL) (gtk-label-set-line-wrap label #t) (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) (let ((frame (gtk-frame-new "Underlined label")) (label (gtk-label-new "This label is underlined!\nThis one is underlined in quite a funky fasion"))) (gtk-label-set-justify label GTK_JUSTIFY_LEFT) (gtk-label-set-pattern label "_________________________ _ _________ _ ______ __ _______ ___") (gtk-container-add frame label) (gtk-box-pack-start vbox frame #f #f 0)) ) ) (gtk-widget-show-all window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/list.scm000066400000000000000000000074511300401456300227360ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: list.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define-constant *list-item-data-key* "list-item-data") (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "GtkList Example") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (let1 vbox (gtk-vbox-new #f 5) (gtk-container-set-border-width vbox 5) (gtk-container-add window vbox) (gtk-widget-show vbox) (let1 scrolled-window (gtk-scrolled-window-new #f #f) (gtk-widget-set-size-request scrolled-window 250 150) (gtk-container-add vbox scrolled-window) (gtk-widget-show scrolled-window) (let1 gtklist (gtk-list-new) (gtk-scrolled-window-add-with-viewport scrolled-window gtklist) (gtk-widget-show gtklist) (g-signal-connect gtklist "selection_changed" sigh-print-selection) (let1 frame (gtk-frame-new "Prison") (gtk-widget-set-size-request frame 200 50) (gtk-container-set-border-width frame 5) (gtk-frame-set-shadow-type frame GTK_SHADOW_OUT) (gtk-container-add vbox frame) (gtk-widget-show frame) (g-signal-connect gtklist "button_release_event" (lambda (w e) (sigh-button-event w e frame)))) (let1 separator (gtk-hseparator-new) (gtk-container-add vbox separator) (gtk-widget-show separator)) (let1 button (gtk-button-new-with-label "Close") (gtk-container-add vbox button) (gtk-widget-show button) (g-signal-connect button "clicked" (lambda _ (gtk-widget-destroy window)))) ;; list items (dotimes (i 5) (let ((label (gtk-label-new #`"ListItemContainer with Label #,i")) (list-item (gtk-list-item-new))) (gtk-container-add list-item label) (gtk-widget-show label) (gtk-container-add gtklist list-item) (gtk-widget-show list-item) (g-object-set-data list-item *list-item-data-key* (gtk-label-get-text label)))) ;; more list items, using gtk-list-append-items (let ((items '())) (dotimes (i 10) (let1 list-item (gtk-list-item-new-with-label #`"List Item with Label ,i") (push! items list-item) (gtk-widget-show list-item) (g-object-set-data list-item *list-item-data-key* "ListItem with integrated Label"))) (gtk-list-append-items gtklist items)) ) ) ) (gtk-widget-show-all window) ) (gtk-main) 0) (define (sigh-button-event gtklist event frame) (when (and (eqv? (slot-ref event 'type) GDK_BUTTON_RELEASE) (eqv? (slot-ref event 'button) 3)) (let* ((selection (slot-ref gtklist 'selection)) (new-prisoner (if (null? selection) #f (car selection)))) (for-each (lambda (w) (when (is-a? w ) (gtk-widget-reparent w gtklist))) (gtk-container-get-children frame)) (when new-prisoner (gtk-list-unselect-child gtklist new-prisoner) (gtk-widget-reparent new-prisoner frame)))) #f) (define (sigh-print-selection gtklist) (let1 selection (slot-ref gtklist 'selection) (if (null? selection) (print "Selection cleared") (format #t "The selection is a ~s\n" (map (cut g-object-get-data <> *list-item-data-key*) selection)))) #f) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/menu.scm000066400000000000000000000040011300401456300227130ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: menu.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-widget-set-size-request window 200 100) (gtk-window-set-title window "GTK Menu Test") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (let1 menu (gtk-menu-new) (dotimes (i 3) (let* ((s #`"Test-undermenu - ,i") (menu-item (gtk-menu-item-new-with-label s))) (gtk-menu-shell-append menu menu-item) (g-signal-connect menu-item "activate" (lambda _ (print s))) (gtk-widget-show menu-item))) (let1 root-menu (gtk-menu-item-new-with-label "Root Menu") (gtk-widget-show root-menu) (gtk-menu-item-set-submenu root-menu menu) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) (let1 menu-bar (gtk-menu-bar-new) (gtk-box-pack-start vbox menu-bar #f #f 2) (gtk-widget-show menu-bar) (let1 button (gtk-button-new-with-label "press me") (g-signal-connect button "event" (lambda (w event) (if (eqv? (ref event 'type) GDK_BUTTON_PRESS) (begin (gtk-menu-popup menu #f #f #f (ref event 'button) (ref event 'time)) #t) #f))) (gtk-box-pack-end vbox button #t #t 2) (gtk-widget-show button)) (gtk-menu-shell-append menu-bar root-menu) )))) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/notebook.scm000066400000000000000000000102761300401456300236020ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: notebook.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (rotate-book notebook) (gtk-notebook-set-tab-pos notebook (modulo (+ (ref notebook 'tab-pos) 1) 4))) (define (tabsborder-book notebook) (let ((tval (zero? (ref notebook 'show-tabs))) (bval (zero? (ref notebook 'show-border)))) (gtk-notebook-set-show-tabs notebook tval) (gtk-notebook-set-show-border notebook bval))) (define (remove-book notebook) (let1 page (gtk-notebook-get-current-page notebook) (gtk-notebook-remove-page notebook page) (gtk-widget-queue-draw notebook))) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (let1 table (gtk-table-new 3 6 #f) (gtk-container-add window table) (let1 notebook (gtk-notebook-new) (gtk-notebook-set-tab-pos notebook GTK_POS_TOP) (gtk-table-attach-defaults table notebook 0 6 0 1) (gtk-widget-show notebook) (dotimes (i 5) (let1 frame (gtk-frame-new #`"Append Frame ,(+ i 1)") (gtk-container-set-border-width frame 10) (gtk-widget-set-size-request frame 100 75) (gtk-widget-show frame) (let1 label (gtk-label-new #`"Append Frame ,(+ i 1)") (gtk-container-add frame label) (gtk-widget-show label)) (let1 label (gtk-label-new #`"Page ,(+ i 1)") (gtk-notebook-append-page notebook frame label)))) (let1 checkbutton (gtk-check-button-new-with-label "Check me please!") (gtk-widget-set-size-request checkbutton 100 75) (gtk-widget-show checkbutton) (let1 label (gtk-label-new "Add page") (gtk-notebook-insert-page notebook checkbutton label 2))) (dotimes (i 5) (let1 frame (gtk-frame-new #`"Prepend Frame ,(+ i 1)") (gtk-container-set-border-width frame 10) (gtk-widget-set-size-request frame 100 75) (gtk-widget-show frame) (let1 label (gtk-label-new #`"Prepend Frame ,(+ i 1)") (gtk-container-add frame label) (gtk-widget-show label)) (let1 label (gtk-label-new #`"PPage ,(+ i 1)") (gtk-notebook-prepend-page notebook frame label)))) (gtk-notebook-set-current-page notebook 3) (let1 button (gtk-button-new-with-label "close") (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-table-attach-defaults table button 0 1 1 2) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "next page") (g-signal-connect button "clicked" (lambda _ (gtk-notebook-next-page notebook) #t)) (gtk-table-attach-defaults table button 1 2 1 2) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "prev page") (g-signal-connect button "clicked" (lambda _ (gtk-notebook-prev-page notebook) #t)) (gtk-table-attach-defaults table button 2 3 1 2) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "tab position") (g-signal-connect button "clicked" (lambda _ (rotate-book notebook) #t)) (gtk-table-attach-defaults table button 3 4 1 2) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "tabs/border on/off") (g-signal-connect button "clicked" (lambda _ (tabsborder-book notebook) #t)) (gtk-table-attach-defaults table button 4 5 1 2) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "remove page") (g-signal-connect button "clicked" (lambda _ (remove-book notebook) #t)) (gtk-table-attach-defaults table button 5 6 1 2) (gtk-widget-show button)) ) (gtk-widget-show table) ) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/packbox.scm000066400000000000000000000111011300401456300233750ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: packbox.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) ;; Note: the delete_event handler is directly created in the main function ;; Make a new hbox filled with button-labels. ;; Note the use of internal function, compared to C version that ;; has to repeat same patterns. (define (make-box homogeneous? spacing expand? fill? padding) (let ((box (gtk-hbox-new homogeneous? spacing))) (define (make-packed-button label) (let ((button (gtk-button-new-with-label label))) (gtk-box-pack-start box button expand? fill? padding) (gtk-widget-show button))) (make-packed-button "gtk_box_pack") (make-packed-button "(box,") (make-packed-button "button,") (make-packed-button (if expand? "TRUE," "FALSE,")) (make-packed-button (if fill? "TRUE," "FALSE,")) (make-packed-button #`",|padding|);") box)) (define (main args) (gtk-init args) (unless (= (length args) 2) (error "usage: packbox num, where num is 1, 2, or 3.")) (let* ((which (string->number (cadr args))) (window (gtk-window-new GTK_WINDOW_TOPLEVEL))) (g-signal-connect window "delete_event" (lambda (w e) (gtk-main-quit) #f)) (gtk-container-set-border-width window 10) (let1 box1 (gtk-vbox-new #f 0) (case which ((1) (let ((make-packed-box (lambda params (let1 box2 (apply make-box params) (gtk-box-pack-start box1 box2 #f #f 0) (gtk-widget-show box2))))) (let1 label (gtk-label-new "gtk-hbox-new (FALSE, 0);") (gtk-misc-set-alignment label 0 0) (gtk-box-pack-start box1 label #f #f 0) (gtk-widget-show label) (make-packed-box #f 0 #f #f 0) (make-packed-box #f 0 #t #f 0) (make-packed-box #f 0 #t #t 0) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start box1 separator #f #t 5) (gtk-widget-show separator)) (let1 label (gtk-label-new "gtk-hbox-new (TRUE, 0);") (gtk-misc-set-alignment label 0 0) (gtk-box-pack-start box1 label #f #f 0) (gtk-widget-show label)) (make-packed-box #t 0 #t #f 0) (make-packed-box #t 0 #t #t 0) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start box1 separator #f #t 5) (gtk-widget-show separator)) ))) ((2) (let ((make-packed-box (lambda params (let1 box2 (apply make-box params) (gtk-box-pack-start box1 box2 #f #f 0) (gtk-widget-show box2))))) (let1 label (gtk-label-new "gtk-hbox-new (FALSE, 10);") (gtk-misc-set-alignment label 0 0) (gtk-box-pack-start box1 label #f #f 0) (gtk-widget-show label) (make-packed-box #f 10 #t #f 0) (make-packed-box #f 10 #t #t 0) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start box1 separator #f #t 5) (gtk-widget-show separator)) (let1 label (gtk-label-new "gtk-hbox-new (FALSE, 0);") (gtk-misc-set-alignment label 0 0) (gtk-box-pack-start box1 label #f #f 0) (gtk-widget-show label)) (make-packed-box #f 0 #t #f 10) (make-packed-box #f 0 #t #t 10) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start box1 separator #f #t 5) (gtk-widget-show separator)) ))) ((3) (let ((box2 (make-box #f 0 #f #f 0))) (let1 label (gtk-label-new "end") (gtk-box-pack-end box2 label #f #f 0) (gtk-widget-show label)) (gtk-box-pack-start box1 box2 #f #f 0) (gtk-widget-show box2) (let1 separator (gtk-hseparator-new) (gtk-widget-set-size-request separator 400 5) (gtk-box-pack-start box1 separator #f #t 5) (gtk-widget-show separator)) )) ) (let ((quitbox (gtk-hbox-new #f 0)) (button (gtk-button-new-with-label "Quit"))) (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-box-pack-start quitbox button #t #f 0) (gtk-box-pack-start box1 quitbox #f #f 0) (gtk-container-add window box1) (gtk-widget-show button) (gtk-widget-show quitbox)) (gtk-widget-show box1)) (gtk-widget-show window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/paned.scm000066400000000000000000000052141300401456300230450ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: paned.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (create-list) (let1 scrolled-window (gtk-scrolled-window-new #f #f) (gtk-scrolled-window-set-policy scrolled-window GTK_POLICY_AUTOMATIC GTK_POLICY_AUTOMATIC) (let ((model (gtk-list-store-new )) (tree-view (gtk-tree-view-new))) (gtk-scrolled-window-add-with-viewport scrolled-window tree-view) (gtk-tree-view-set-model tree-view model) (gtk-widget-show tree-view) (dotimes (i 10) (let1 iter (gtk-list-store-append model) (gtk-list-store-set-value model iter 0 #`"Message #,i"))) (let* ((cell (gtk-cell-renderer-text-new)) (column (gtk-tree-view-column-new-with-attributes "Messages" cell "text" 0))) (gtk-tree-view-append-column tree-view column))) scrolled-window) ) (define (insert-text buffer) (let1 iter (gtk-text-buffer-get-iter-at-offset buffer 0) (gtk-text-buffer-insert buffer iter "From: pathfinder@nasa.gov\nTo: mom@nasa.gov\nSubject: Made it!\n\nWe just got in this morning. The weather has been\ngreat - clear but cold, and there are lots of fun sights.\nSojourner says hi. See you soon.\n -Path\n" -1)) ) (define (create-text) (let* ((view (gtk-text-view-new)) (buffer (gtk-text-view-get-buffer view)) (scrolled-window (gtk-scrolled-window-new #f #f))) (gtk-scrolled-window-set-policy scrolled-window GTK_POLICY_AUTOMATIC GTK_POLICY_AUTOMATIC) (gtk-container-add scrolled-window view) (insert-text buffer) (gtk-widget-show-all scrolled-window) scrolled-window)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Paned Window") (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (gtk-widget-set-size-request window 450 400) (let1 vpaned (gtk-vpaned-new) (gtk-container-add window vpaned) (gtk-widget-show vpaned) (let1 list (create-list) (gtk-paned-add1 vpaned list) (gtk-widget-show list)) (let1 text (create-text) (gtk-paned-add2 vpaned text) (gtk-widget-show text))) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/pixmap.scm000066400000000000000000000030301300401456300232460ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: pixmap.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define *xpm-data* '("16 16 3 1" " c None" ". c #000000000000" "X c #FFFFFFFFFFFF" " " " ...... " " .XXX.X. " " .XXX.XX. " " .XXX.XXX. " " .XXX..... " " .XXXXXXX. " " .XXXXXXX. " " .XXXXXXX. " " .XXXXXXX. " " .XXXXXXX. " " .XXXXXXX. " " .XXXXXXX. " " ......... " " " " ")) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (gtk-container-set-border-width window 10) (gtk-widget-show window) (let1 style (gtk-widget-get-style window) (receive (pixmap mask) (gdk-pixmap-create-from-xpm-d (ref window 'window) (ref (ref style 'bg) GTK_STATE_NORMAL) *xpm-data*) (let1 pixmapwid (gtk-pixmap-new pixmap mask) (gtk-widget-show pixmapwid) (let1 button (gtk-button-new) (gtk-container-add button pixmapwid) (gtk-container-add window button) (gtk-widget-show button) (g-signal-connect button "clicked" (lambda _ (print "button clicked")))) ))) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/progressbar.scm000066400000000000000000000112161300401456300243060ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: progressbar.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define-class () ((window :init-keyword :window) (pbar :init-keyword :pbar) (timer :init-keyword :timer) (activity-mode :init-keyword :activity-mode :initform #f) )) (define-method progress-timeout ((pdata )) (if (ref pdata 'activity-mode) (gtk-progress-bar-pulse (ref pdata 'pbar)) (let1 new-val (fmod (+ (gtk-progress-bar-get-fraction (ref pdata 'pbar)) 0.01) 1.0) (gtk-progress-bar-set-fraction (ref pdata 'pbar) new-val))) #t) (define-method toggle-show-text ((pdata )) (let1 text (gtk-progress-bar-get-text (ref pdata 'pbar)) (if (and text (not (string=? text ""))) (gtk-progress-bar-set-text (ref pdata 'pbar) "") (gtk-progress-bar-set-text (ref pdata 'pbar) "some text")))) (define-method toggle-activity-mode ((pdata )) (update! (ref pdata 'activity-mode) not) (if (ref pdata 'activity-mode) (gtk-progress-bar-pulse (ref pdata 'pbar)) (gtk-progress-bar-set-fraction (ref pdata 'pbar) 0.0))) (define-method toggle-orientation ((pdata )) (let1 mode (gtk-progress-bar-get-orientation (ref pdata 'pbar)) (cond ((eqv? mode GTK_PROGRESS_LEFT_TO_RIGHT) (gtk-progress-bar-set-orientation (ref pdata 'pbar) GTK_PROGRESS_RIGHT_TO_LEFT)) ((eqv? mode GTK_PROGRESS_RIGHT_TO_LEFT) (gtk-progress-bar-set-orientation (ref pdata 'pbar) GTK_PROGRESS_LEFT_TO_RIGHT)) ))) (define-method destroy-progress ((pdata )) (gtk-timeout-remove (ref pdata 'timer)) (gtk-main-quit)) (define (main args) (gtk-init args) (let1 pdata (make :window (gtk-window-new GTK_WINDOW_TOPLEVEL) :pbar (gtk-progress-bar-new)) (gtk-window-set-resizable (ref pdata 'window) #t) (g-signal-connect (ref pdata 'window) "destroy" (lambda _ (destroy-progress pdata))) (gtk-window-set-title (ref pdata 'window) "GtkProgressBar") (gtk-container-set-border-width (ref pdata 'window) 0) (let1 vbox (gtk-vbox-new #f 5) (gtk-container-set-border-width vbox 10) (gtk-container-add (ref pdata 'window) vbox) (gtk-widget-show vbox) (let1 align (gtk-alignment-new 0.5 0.5 0 0) (gtk-box-pack-start vbox align #f #f 5) (gtk-widget-show align) (gtk-container-add align (ref pdata 'pbar)) (gtk-widget-show (ref pdata 'pbar)) (set! (ref pdata 'timer) (gtk-timeout-add 100 (lambda _ (progress-timeout pdata)))) ) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start vbox separator #f #f 0) (gtk-widget-show separator)) (let1 table (gtk-table-new 2 2 #f) (gtk-box-pack-start vbox table #f #t 0) (gtk-widget-show table) (let1 check (gtk-check-button-new-with-label "Show text") (gtk-table-attach table check 0 1 0 1 (logior GTK_EXPAND GTK_FILL) (logior GTK_EXPAND GTK_FILL) 5 5) (g-signal-connect check "clicked" (lambda _ (toggle-show-text pdata))) (gtk-widget-show check)) (let1 check (gtk-check-button-new-with-label "Activity mode") (gtk-table-attach table check 0 1 1 2 (logior GTK_EXPAND GTK_FILL) (logior GTK_EXPAND GTK_FILL) 5 5) (g-signal-connect check "clicked" (lambda _ (toggle-activity-mode pdata))) (gtk-widget-show check)) (let1 check (gtk-check-button-new-with-label "Right to Left") (gtk-table-attach table check 0 1 2 3 (logior GTK_EXPAND GTK_FILL) (logior GTK_EXPAND GTK_FILL) 5 5) (g-signal-connect check "clicked" (lambda _ (toggle-orientation pdata))) (gtk-widget-show check)) ) (let1 button (gtk-button-new-with-label "close") (g-signal-connect button "clicked" (lambda _ (gtk-widget-destroy (ref pdata 'window)))) (gtk-box-pack-start vbox button #f #f 0) (gtk-widget-set-flags button GTK_CAN_DEFAULT) (gtk-widget-grab-default button) (gtk-widget-show button)) ) (gtk-widget-show (ref pdata 'window)) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/radiobuttons.scm000066400000000000000000000037111300401456300244730ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: radiobuttons.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (gtk-window-set-title window "radio buttons") (gtk-container-set-border-width window 0) (let1 box1 (gtk-vbox-new #f 0) (gtk-container-add window box1) (gtk-widget-show box1) (let1 box2 (gtk-vbox-new #f 10) (gtk-container-set-border-width box2 10) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2) (let1 button1 (gtk-radio-button-new-with-label #f "button1") (gtk-box-pack-start box2 button1 #t #t 0) (gtk-widget-show button1) (let* ((group (gtk-radio-button-get-group button1)) (button2 (gtk-radio-button-new-with-label group "button2"))) (gtk-toggle-button-set-active button2 #t) (gtk-box-pack-start box2 button2 #t #t 0) (gtk-widget-show button2) (let1 button3 (gtk-radio-button-new-with-label-from-widget button2 "button3") (gtk-box-pack-start box2 button3 #t #t 0) (gtk-widget-show button3)) ) ) ) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start box1 separator #f #t 0) (gtk-widget-show separator)) (let1 box2 (gtk-vbox-new #f 10) (gtk-container-set-border-width box2 10) (gtk-box-pack-start box1 box2 #f #t 0) (gtk-widget-show box2) (let1 button (gtk-button-new-with-label "close") (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-box-pack-start box2 button #t #t 0) (gtk-widget-set-flags button GTK_CAN_DEFAULT) (gtk-widget-show button))) ) (gtk-widget-show window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/rangewidgets.scm000066400000000000000000000166211300401456300244450ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: rangewidgets.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (make-menu-item name callback) (let1 item (gtk-menu-item-new-with-label name) (g-signal-connect item "activate" callback) (gtk-widget-show item) item)) (define (create-range-controls) (let* ((window (gtk-window-new GTK_WINDOW_TOPLEVEL)) (adj1 (gtk-adjustment-new 0.0 0.0 101.0 0.1 1.0 1.0)) (vscale (gtk-vscale-new adj1)) (hscale (gtk-hscale-new adj1))) (define (scale-set-default-values scale) (gtk-range-set-update-policy scale GTK_UPDATE_CONTINUOUS) (gtk-scale-set-digits scale 1) (gtk-scale-set-value-pos scale GTK_POS_TOP) (gtk-scale-set-draw-value scale #t)) (g-signal-connect window "destroy" (lambda _ (gtk-main-quit))) (gtk-window-set-title window "range controls") (let1 box1 (gtk-vbox-new #f 0) (gtk-container-add window box1) (gtk-widget-show box1) (let1 box2 (gtk-hbox-new #f 10) (gtk-container-set-border-width box2 10) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2) (scale-set-default-values vscale) (gtk-box-pack-start box2 vscale #t #t 0) (gtk-widget-show vscale) (let1 box3 (gtk-vbox-new #f 10) (gtk-box-pack-start box2 box3 #t #t 0) (gtk-widget-show box3) (gtk-widget-set-size-request hscale 200 -1) (scale-set-default-values hscale) (gtk-box-pack-start box3 hscale #t #t 0) (gtk-widget-show hscale) (let1 scrollbar (gtk-hscrollbar-new adj1) (gtk-range-set-update-policy scrollbar GTK_UPDATE_CONTINUOUS) (gtk-box-pack-start box3 scrollbar #t #t 0) (gtk-widget-show scrollbar)) ) ) (let1 box2 (gtk-hbox-new #f 10) (gtk-container-set-border-width box2 10) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2) (let1 button (gtk-check-button-new-with-label "Display value on scale widgets") (gtk-toggle-button-set-active button #t) (g-signal-connect button "toggled" (lambda _ (for-each (cut gtk-scale-set-draw-value <> (not (zero? (ref button 'active)))) (list hscale vscale)))) (gtk-box-pack-start box2 button #t #t 0) (gtk-widget-show button))) (let1 box2 (gtk-hbox-new #f 10) (gtk-container-set-border-width box2 10) (let1 label (gtk-label-new "Scale Value Position:") (gtk-box-pack-start box2 label #f #f 0) (gtk-widget-show label)) (let ((opt (gtk-option-menu-new)) (menu (gtk-menu-new))) (for-each (lambda (label pos) (let1 item (make-menu-item label (lambda _ (for-each (cut gtk-scale-set-value-pos <> pos) (list vscale hscale)))) (gtk-menu-shell-append menu item))) '("Top" "Bottom" "Left" "Right") `(,GTK_POS_TOP ,GTK_POS_BOTTOM ,GTK_POS_LEFT ,GTK_POS_RIGHT)) (gtk-option-menu-set-menu opt menu) (gtk-box-pack-start box2 opt #t #t 0) (gtk-widget-show opt)) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2)) (let1 box2 (gtk-hbox-new #f 10) (gtk-container-set-border-width box2 10) (let1 label (gtk-label-new "Scale Update Policy:") (gtk-box-pack-start box2 label #f #f 0) (gtk-widget-show label)) (let ((opt (gtk-option-menu-new)) (menu (gtk-menu-new))) (for-each (lambda (label policy) (let1 item (make-menu-item label (lambda _ (for-each (cut gtk-range-set-update-policy <> policy) (list vscale hscale)))) (gtk-menu-shell-append menu item))) '("Continuous" "Discontinuous" "Delayed") `(,GTK_UPDATE_CONTINUOUS ,GTK_UPDATE_DISCONTINUOUS ,GTK_UPDATE_DELAYED)) (gtk-option-menu-set-menu opt menu) (gtk-box-pack-start box2 opt #t #t 0) (gtk-widget-show opt)) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2)) (let1 box2 (gtk-hbox-new #f 10) (gtk-container-set-border-width box2 10) (let1 label (gtk-label-new "Scale Digits:") (gtk-box-pack-start box2 label #f #f 0) (gtk-widget-show label)) (let1 adj2 (gtk-adjustment-new 1.0 0.0 5.0 1.0 1.0 0.0) (g-signal-connect adj2 "value_changed" (lambda _ (for-each (cut gtk-scale-set-digits <> (inexact->exact (round (ref adj2 'value)))) (list hscale vscale)))) (let1 scale (gtk-hscale-new adj2) (gtk-scale-set-digits scale 0) (gtk-box-pack-start box2 scale #t #t 0) (gtk-widget-show scale)) ) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2)) (let1 box2 (gtk-hbox-new #f 10) (gtk-container-set-border-width box2 10) (let1 label (gtk-label-new "Scrollbar Page Size:") (gtk-box-pack-start box2 label #f #f 0) (gtk-widget-show label)) (let1 adj2 (gtk-adjustment-new 1.0 1.0 101.0 1.0 1.0 0.0) (g-signal-connect adj2 "value_changed" (lambda _ (set! (ref adj1 'page-size) (ref adj2 'value)) (set! (ref adj1 'page-increment) (ref adj2 'value)) (gtk-adjustment-set-value adj1 (clamp (ref adj1 'value) (ref adj1 'lower) (- (ref adj1 'upper) (ref adj1 'page-size)))))) (let1 scale (gtk-hscale-new adj2) (gtk-scale-set-digits scale 0) (gtk-box-pack-start box2 scale #t #t 0) (gtk-widget-show scale)) ) (gtk-box-pack-start box1 box2 #t #t 0) (gtk-widget-show box2)) (let1 separator (gtk-hseparator-new) (gtk-box-pack-start box1 separator #f #t 0) (gtk-widget-show separator)) (let1 box2 (gtk-vbox-new #f 10) (gtk-container-set-border-width box2 10) (gtk-box-pack-start box1 box2 #f #t 0) (gtk-widget-show box2) (let1 button (gtk-button-new-with-label "Quit") (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-box-pack-start box2 button #t #t 0) (gtk-widget-set-flags button GTK_CAN_DEFAULT) (gtk-widget-grab-default button) (gtk-widget-show button))) ) ; box1 (gtk-widget-show window) ) ) (define (main args) (gtk-init args) (create-range-controls) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/scrolledwin.scm000066400000000000000000000034171300401456300243060ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: scrolledwin.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (main args) (gtk-init args) (let1 window (gtk-dialog-new) (g-signal-connect window "destroy" (lambda _ (gtk-main-quit) #f)) (gtk-window-set-title window "GtkScrolledWindow example") (gtk-container-set-border-width window 0) (gtk-widget-set-size-request window 300 300) (let1 scrolled-window (gtk-scrolled-window-new #f #f) (gtk-container-set-border-width scrolled-window 10) (gtk-scrolled-window-set-policy scrolled-window GTK_POLICY_AUTOMATIC GTK_POLICY_ALWAYS) (gtk-box-pack-start (ref window 'vbox) scrolled-window #t #t 0) (gtk-widget-show scrolled-window) (let1 table (gtk-table-new 10 10 #f) (gtk-table-set-row-spacings table 10) (gtk-table-set-col-spacings table 10) (gtk-scrolled-window-add-with-viewport scrolled-window table) (gtk-widget-show table) (dotimes (i 10) (dotimes (j 10) (let1 button (gtk-toggle-button-new-with-label (format #f "button (~s,~s)" i j)) (gtk-table-attach-defaults table button i (+ i 1) j (+ j 1)) (gtk-widget-show button)))) ) ;table ) ; scrolled-window (let1 button (gtk-button-new-with-label "close") (g-signal-connect button "clicked" (lambda _ (gtk-widget-destroy window))) (gtk-widget-set-flags button GTK_CAN_DEFAULT) (gtk-box-pack-start (ref window 'action-area) button #t #t 0) (gtk-widget-grab-default button) (gtk-widget-show button)) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/spinbutton.scm000066400000000000000000000154601300401456300241670ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: spinbutton.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define *spinner1* #f) (define (toggle-snap button spin) (gtk-spin-button-set-snap-to-ticks spin (not (zero? (ref button 'active))))) (define (toggle-numeric button spin) (gtk-spin-button-set-numeric spin (not (zero? (ref button 'active))))) (define (change-digits spin) (gtk-spin-button-set-digits *spinner1* (gtk-spin-button-get-value-as-int spin))) (define (get-value widget data) (let ((spin *spinner1*) (label (g-object-get-data widget 'user_data))) (gtk-label-set-text label (if (= data 1) (number->string (gtk-spin-button-get-value-as-int spin)) (number->string (gtk-spin-button-get-value spin)))))) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect window "destroy" (lambda _ (gtk-main-quit) #f)) (gtk-window-set-title window "Spin Button") (let1 main-vbox (gtk-vbox-new #f 5) (gtk-container-set-border-width main-vbox 10) (gtk-container-add window main-vbox) (let1 frame (gtk-frame-new "Not accelerated") (gtk-box-pack-start main-vbox frame #t #t 0) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-set-border-width vbox 5) (gtk-container-add frame vbox) (let1 hbox (gtk-hbox-new #f 0) (gtk-box-pack-start vbox hbox #t #t 5) (let1 vbox2 (gtk-vbox-new #f 0) (gtk-box-pack-start hbox vbox2 #t #t 5) (let1 label (gtk-label-new "Day :") (gtk-misc-set-alignment label 0 0.5) (gtk-box-pack-start vbox2 label #f #t 0)) (let* ((adj (gtk-adjustment-new 1.0 1.0 31.0 1.0 5.0 0.0)) (spinner (gtk-spin-button-new adj 0 0))) (gtk-spin-button-set-wrap spinner #t) (gtk-box-pack-start vbox2 spinner #f #t 0))) (let1 vbox2 (gtk-vbox-new #f 0) (gtk-box-pack-start hbox vbox2 #t #t 5) (let1 label (gtk-label-new "Month :") (gtk-misc-set-alignment label 0 0.5) (gtk-box-pack-start vbox2 label #f #t 0)) (let* ((adj (gtk-adjustment-new 1.0 1.0 12.0 1.0 5.0 0.0)) (spinner (gtk-spin-button-new adj 0 0))) (gtk-spin-button-set-wrap spinner #t) (gtk-box-pack-start vbox2 spinner #f #t 0))) (let1 vbox2 (gtk-vbox-new #f 0) (gtk-box-pack-start hbox vbox2 #t #t 5) (let1 label (gtk-label-new "Year :") (gtk-misc-set-alignment label 0 0.5) (gtk-box-pack-start vbox2 label #f #t 0)) (let* ((adj (gtk-adjustment-new 1998.0 0.0 2100.0 1.0 100.0 0.0)) (spinner (gtk-spin-button-new adj 0 0))) (gtk-spin-button-set-wrap spinner #f) (gtk-widget-set-size-request spinner 55 -1) (gtk-box-pack-start vbox2 spinner #f #t 0))) ) ;hbox ) ;vbox ) ;frame (let1 frame (gtk-frame-new "Accelerated") (gtk-box-pack-start main-vbox frame #t #t 0) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-set-border-width vbox 5) (gtk-container-add frame vbox) (let1 hbox (gtk-hbox-new #f 0) (gtk-box-pack-start vbox hbox #f #t 5) (let1 vbox2 (gtk-vbox-new #f 0) (gtk-box-pack-start hbox vbox2 #t #t 5) (let1 label (gtk-label-new "Value :") (gtk-misc-set-alignment label 0 0.5) (gtk-box-pack-start vbox2 label #f #t 0)) (let ((adj (gtk-adjustment-new 0.0 -10000.0 10000.0 0.5 100.0 0.0))) (set! *spinner1* (gtk-spin-button-new adj 1.0 2))) (gtk-spin-button-set-wrap *spinner1* #t) (gtk-widget-set-size-request *spinner1* 100 -1) (gtk-box-pack-start vbox2 *spinner1* #f #t 0)) (let1 vbox2 (gtk-vbox-new #f 0) (gtk-box-pack-start hbox vbox2 #t #t 0) (let1 label (gtk-label-new "Digits :") (gtk-misc-set-alignment label 0 0.5) (gtk-box-pack-start vbox2 label #f #t 0) (let* ((adj (gtk-adjustment-new 2 1 5 1 1 0)) (spinner2 (gtk-spin-button-new adj 0.0 0))) (gtk-spin-button-set-wrap spinner2 #t) (g-signal-connect adj "value_changed" (lambda _ (change-digits spinner2))) (gtk-box-pack-start vbox2 spinner2 #f #t 0)))) ) ; hbox (let1 hbox (gtk-hbox-new #f 0) (gtk-box-pack-start vbox hbox #f #t 5) (let1 button (gtk-check-button-new-with-label "Snap to 0.5-ticks") (g-signal-connect button "clicked" (lambda _ (toggle-snap button *spinner1*))) (gtk-box-pack-start vbox button #t #t 0) (gtk-toggle-button-set-active button #t)) (let1 button (gtk-check-button-new-with-label "Numeric only input mode") (g-signal-connect button "clicked" (lambda _ (toggle-numeric button *spinner1*))) (gtk-box-pack-start vbox button #t #t 0) (gtk-toggle-button-set-active button #t))) (let ((val-label (gtk-label-new "")) (hbox (gtk-hbox-new #f 0))) (gtk-box-pack-start vbox hbox #f #t 5) (let1 button (gtk-button-new-with-label "Value as Int") (g-object-set-data button 'user_data val-label) (g-signal-connect button "clicked" (lambda _ (get-value button 1))) (gtk-box-pack-start hbox button #t #t 5)) (let1 button (gtk-button-new-with-label "Value as Float") (g-object-set-data button 'user_data val-label) (g-signal-connect button "clicked" (lambda _ (get-value button 2))) (gtk-box-pack-start hbox button #t #t 5)) (gtk-box-pack-start vbox val-label #t #t 0) (gtk-label-set-text val-label "0")) ) ; vbox ) ; frame (let1 hbox (gtk-hbox-new #f 0) (gtk-box-pack-start main-vbox hbox #f #t 0) (let1 button (gtk-button-new-with-label "Close") (g-signal-connect button "clicked" (lambda _ (gtk-widget-destroy window))) (gtk-box-pack-start hbox button #t #t 5))) ) ; main-vbox (gtk-widget-show-all window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/statusbar.scm000066400000000000000000000031031300401456300237610ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: statusbar.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define push-item (let ((count 1)) (lambda (sbar data) (gtk-statusbar-push sbar data #`"item ,count") (inc! count)))) (define (pop-item sbar data) (gtk-statusbar-pop sbar data)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-widget-set-size-request window 200 100) (gtk-window-set-title window "GTK Statusbar Example") (g-signal-connect window "delete_event" (lambda _ (exit))) (let1 vbox (gtk-vbox-new #f 1) (gtk-container-add window vbox) (gtk-widget-show vbox) (let1 status-bar (gtk-statusbar-new) (gtk-box-pack-start vbox status-bar #t #t 0) (gtk-widget-show status-bar) (let1 context-id (gtk-statusbar-get-context-id status-bar "Statusbar example") (let1 button (gtk-button-new-with-label "push item") (g-signal-connect button "clicked" (lambda _ (push-item status-bar context-id))) (gtk-box-pack-start vbox button #t #t 2) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "pop last item") (g-signal-connect button "clicked" (lambda _ (pop-item status-bar context-id))) (gtk-box-pack-start vbox button #t #t 2) (gtk-widget-show button)) )) ) (gtk-widget-show window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/table.scm000066400000000000000000000025651300401456300230530ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: table.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define (callback data) (format #t "Hello again - ~s was pressed\n" data)) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "Table") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit) #f)) (gtk-container-set-border-width window 20) (let1 table (gtk-table-new 2 2 #t) (gtk-container-add window table) (let1 button (gtk-button-new-with-label "button 1") (g-signal-connect button "clicked" (lambda (w) (callback "button 1"))) (gtk-table-attach-defaults table button 0 1 0 1) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "button 2") (g-signal-connect button "clicked" (lambda (w) (callback "button 2"))) (gtk-table-attach-defaults table button 1 2 0 1) (gtk-widget-show button)) (let1 button (gtk-button-new-with-label "Quit") (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-table-attach-defaults table button 0 2 1 2) (gtk-widget-show button)) (gtk-widget-show table)) (gtk-widget-show window)) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtk-tutorial/wheelbarrow.scm000066400000000000000000000131061300401456300242760ustar00rootroot00000000000000;; ;; Simple example, ported from the one in Gtk+2.0 tutorial. ;; ;; $Id: wheelbarrow.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $ (use gtk) (define *wheelbarrow-full-xpm* '("48 48 64 1" " c None" ". c #DF7DCF3CC71B" "X c #965875D669A6" "o c #71C671C671C6" "O c #A699A289A699" "+ c #965892489658" "@ c #8E38410330C2" "# c #D75C7DF769A6" "$ c #F7DECF3CC71B" "% c #96588A288E38" "& c #A69992489E79" "* c #8E3886178E38" "= c #104008200820" "- c #596510401040" "; c #C71B30C230C2" ": c #C71B9A699658" "> c #618561856185" ", c #20811C712081" "< c #104000000000" "1 c #861720812081" "2 c #DF7D4D344103" "3 c #79E769A671C6" "4 c #861782078617" "5 c #41033CF34103" "6 c #000000000000" "7 c #49241C711040" "8 c #492445144924" "9 c #082008200820" "0 c #69A618611861" "q c #B6DA71C65144" "w c #410330C238E3" "e c #CF3CBAEAB6DA" "r c #71C6451430C2" "t c #EFBEDB6CD75C" "y c #28A208200820" "u c #186110401040" "i c #596528A21861" "p c #71C661855965" "a c #A69996589658" "s c #30C228A230C2" "d c #BEFBA289AEBA" "f c #596545145144" "g c #30C230C230C2" "h c #8E3882078617" "j c #208118612081" "k c #38E30C300820" "l c #30C2208128A2" "z c #38E328A238E3" "x c #514438E34924" "c c #618555555965" "v c #30C2208130C2" "b c #38E328A230C2" "n c #28A228A228A2" "m c #41032CB228A2" "M c #104010401040" "N c #492438E34103" "B c #28A2208128A2" "V c #A699596538E3" "C c #30C21C711040" "Z c #30C218611040" "A c #965865955965" "S c #618534D32081" "D c #38E31C711040" "F c #082000000820" " " " .XoO " " +@#$%o& " " *=-;#::o+ " " >,<12#:34 " " 45671#:X3 " " +89<02qwo " "e* >,67;ro " "ty> 459@>+&& " "$2u+ > " "Oh$;ya *3d.a8j,Xe.d3g8+ " " Oh$;ka *3d$a8lz,,xxc:.e3g54 " " Oh$;kO *pd$%svbzz,sxxxxfX..&wn> " " Oh$@mO *3dthwlsslszjzxxxxxxx3:td8M4 " " Oh$@g& *3d$XNlvvvlllm,mNwxxxxxxxfa.:,B* " " Oh$@,Od.czlllllzlmmqV@V#V@fxxxxxxxf:%j5& " " Oh$1hd5lllslllCCZrV#r#:#2AxxxxxxxxxcdwM* " " OXq6c.%8vvvllZZiqqApA:mq:Xxcpcxxxxxfdc9* " " 2r<6gde3bllZZrVi7S@SV77A::qApxxxxxxfdcM " " :,q-6MN.dfmZZrrSS:#riirDSAX@Af5xxxxxfevo" " +A26jguXtAZZZC7iDiCCrVVii7Cmmmxxxxxx%3g" " *#16jszN..3DZZZZrCVSA2rZrV7Dmmwxxxx&en" " p2yFvzssXe:fCZZCiiD7iiZDiDSSZwwxx8e*>" " OA1666 >=01-kuu666> " " ,6ky& &46-10ul,66, " " Ou0<> o66y66By7=xu664 " " <> +66uv,zN666* " " 566,xxj669 " " 4666FF666> " " >966666M " " oM6668+ " " *4 " " " " " )) (define (main args) (gtk-init args) (let1 window (gtk-window-new GTK_WINDOW_POPUP) (gtk-window-set-title window "Table") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit) #f)) (gtk-widget-show window) (let* ((style (gtk-widget-get-default-style)) (gc (ref style 'black-gc))) (receive (gdk-pixmap mask) (gdk-pixmap-create-from-xpm-d (ref window 'window) (ref (ref style 'bg) GTK_STATE_NORMAL) *wheelbarrow-full-xpm*) (let1 pixmap (gtk-image-new-from-pixmap gdk-pixmap mask) (gtk-widget-show pixmap) (let1 fixed (gtk-fixed-new) (gtk-widget-set-size-request fixed 200 200) (gtk-fixed-put fixed pixmap 0 0) (gtk-container-add window fixed) (gtk-widget-show fixed)) (gtk-widget-shape-combine-mask window mask 0 0)))) (gtk-widget-show window) ) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtkglext/000077500000000000000000000000001300401456300204535ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/examples/gtkglext/README000066400000000000000000000003361300401456300213350ustar00rootroot00000000000000This directory contains example scripts ported from gtkglext examples. Requires Gauche-gl installed. To run scripts before installing Gauche-gtk, type like this: gosh -I../../src -I../../lib -I../../gtkgl example.scm gauche-gtk-0.6+git20160927/examples/gtkglext/font.scm000066400000000000000000000160321300401456300221270ustar00rootroot00000000000000;; ;; Simple bitmap font rendering example. ;; ;; Ported from examples/font.c, ;; written by Naofumi Yasufuku ;; (use gauche.collection) (use gauche.uvector) (use gtk) (use gtk.gtkgl) (use gl) (define *font-string* "courier 12") (define *font-list-base* 0) (define *font-height* 0) (define-syntax prval (syntax-rules () ((_ expr) (format #f "~s = ~a" 'expr expr)))) (define-syntax prattr (syntax-rules () ((_ glconfig name bool?) (receive (status value) (gdk-gl-config-get-attrib glconfig name) (if status (format #f "~s = ~s" 'name (if bool? (not (zero? value)) value)) (format #f "~s : failed to get attribute value" 'name)))))) (define (examine-gl-config-attrib glconfig) (print "\nOpenGL visual configurations :\n") (print (prval (gdk-gl-config-is-rgba glconfig))) (print (prval (gdk-gl-config-is-double-buffered glconfig))) (print (prval (gdk-gl-config-is-stereo glconfig))) (print (prval (gdk-gl-config-has-alpha glconfig))) (print (prval (gdk-gl-config-has-depth-buffer glconfig))) (print (prval (gdk-gl-config-has-accum-buffer glconfig))) (print) (print (prattr glconfig GDK_GL_USE_GL #t)) (print (prattr glconfig GDK_GL_BUFFER_SIZE #f)) (print (prattr glconfig GDK_GL_LEVEL #f)) (print (prattr glconfig GDK_GL_RGBA #t)) (print (prattr glconfig GDK_GL_DOUBLEBUFFER #t)) (print (prattr glconfig GDK_GL_STEREO #t)) (print (prattr glconfig GDK_GL_AUX_BUFFERS #f)) (print (prattr glconfig GDK_GL_RED_SIZE #f)) (print (prattr glconfig GDK_GL_GREEN_SIZE #f)) (print (prattr glconfig GDK_GL_BLUE_SIZE #f)) (print (prattr glconfig GDK_GL_ALPHA_SIZE #f)) (print (prattr glconfig GDK_GL_DEPTH_SIZE #f)) (print (prattr glconfig GDK_GL_STENCIL_SIZE #f)) (print (prattr glconfig GDK_GL_ACCUM_RED_SIZE #f)) (print (prattr glconfig GDK_GL_ACCUM_GREEN_SIZE #f)) (print (prattr glconfig GDK_GL_ACCUM_BLUE_SIZE #f)) (print (prattr glconfig GDK_GL_ACCUM_ALPHA_SIZE #f)) (print) ) (define (init widget) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget)) (wsize (ref widget 'allocation))) (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (let* ((font-list-base (gl-gen-lists 128)) (font-desc (pango-font-description-from-string *font-string*)) (font (gdk-gl-font-use-pango-font font-desc 0 128 font-list-base))) (unless font (errorf "*** Can't load font '~s'" *font-string*)) (set! *font-list-base* font-list-base) (let1 font-metrics (pango-font-get-metrics font #f) (set! *font-height* (pango-pixels (+ (pango-font-metrics-get-ascent font-metrics) (pango-font-metrics-get-descent font-metrics)))))) (gl-clear-color 1.0 1.0 1.0 1.0) (gl-clear-depth 1.0) (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height)) (gl-matrix-mode GL_PROJECTION) (gl-load-identity) (gl-ortho 0.0 (ref wsize 'width) 0.0 (ref wsize 'height) -1.0 1.0) (gl-matrix-mode GL_MODELVIEW) (gl-load-identity) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** )) (define (reshape widget . _) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget)) (wsize (ref widget 'allocation))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height)) (gl-matrix-mode GL_PROJECTION) (gl-load-identity) (gl-ortho 0.0 (ref wsize 'width) 0.0 (ref wsize 'height) -1.0 1.0) (gl-matrix-mode GL_MODELVIEW) (gl-load-identity) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** #t)) ;; this should be in Gauche core ... (define (string->u8vector string) (with-builder ( put! get :size (string-size string)) (with-input-from-string string (lambda () (port-for-each put! read-byte))) (get))) (define (display widget . _) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (gl-color 0.0 0.0 0.0) (do ((i 2 (- i 1))) ((< i -2)) (gl-raster-pos 10.0 (+ (* 0.5 (ref (ref widget 'allocation) 'height)) (* i *font-height*))) (do ((j (char->integer #\space) (+ j 1))) ((> j (char->integer #\Z))) (gl-call-list (+ *font-list-base* j)))) (gl-color 1.0 0.0 0.0) (gl-raster-pos 10.0 10.0) (gl-list-base *font-list-base*) (let1 array (string->u8vector *font-string*) ;;ugh... (gl-call-lists array)) (if (gdk-gl-drawable-is-double-buffered gldrawable) (gdk-gl-drawable-swap-buffers gldrawable) (gl-flush)) (gdk-gl-drawable-gl-end gldrawable) ;;*** OpenGL END *** ) #t)) (define (main args) (gtk-init args) (unless (gdk-gl-query-extension) (error "*** OpenGL is not suppotred.***")) (call-with-values gdk-gl-query-version (cut format #t "OpenGL is supported - version ~*~a.~a\n" <> <> <>)) (let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DOUBLE)) (begin (warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n") (gdk-gl-config-new-by-mode GDK_GL_MODE_RGB)) (error "*** No appropriate OpenGL-capable visual found.\n") ) (examine-gl-config-attrib glconfig) (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "font") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit)) #f) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) (let1 drawing-area (gtk-drawing-area-new) (gtk-widget-set-size-request drawing-area 640 240) (gtk-widget-set-gl-capability drawing-area glconfig #f #t GDK_GL_RGBA_TYPE) (gtk-box-pack-start vbox drawing-area #t #t 0) (gtk-widget-set-events drawing-area (logior GDK_EXPOSURE_MASK GDK_BUTTON_PRESS_MASK)) (g-signal-connect drawing-area "realize" init) (g-signal-connect drawing-area "configure_event" reshape) (g-signal-connect drawing-area "expose_event" display) (gtk-widget-show drawing-area)) (let1 button (gtk-button-new-with-label "Quit") (gtk-box-pack-start vbox button #f #f 0) (g-signal-connect button "clicked" (lambda _ (gtk-main-quit)) #f) (gtk-widget-show button)) ) (gtk-widget-show window) )) (gtk-main) 0) gauche-gtk-0.6+git20160927/examples/gtkglext/gears.scm000066400000000000000000000322141300401456300222620ustar00rootroot00000000000000;; ;; 3-D gear wheels. This program is in the public domain. ;; ;; Brian Paul ;; ;; Conversion to GLUT by Mark J. Kilgard ;; Conversion to GtkGLExt by Naofumi Yasufuku ;; Port to Scheme by Shiro Kawai (use math.const) (use gtk) (use gtk.gtkgl) (use gl) ;; Draw a gear wheel. You'll probably want to call this function when ;; building a display list since we do a lot of trig here. ;; ;; Input: inner_radius - radius of hole at center ;; outer_radius - radius at center of teeth ;; width - width of gear ;; teeth - number of teeth ;; tooth_depth - depth of tooth (define (gear inner-radius outer-radius width teeth tooth-depth) (let ((r0 inner-radius) (r1 (- outer-radius (/ tooth-depth 2.0))) (r2 (+ outer-radius (/ tooth-depth 2.0))) (da (* 2.0 (/ pi teeth 4.0)))) (gl-shade-model GL_FLAT) (gl-normal 0.0 0.0 1.0) ;; draw front face (gl-begin GL_QUAD_STRIP) (dotimes (i (+ teeth 1)) (let1 angle (* i 2.0 (/ pi teeth)) (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (when (< i teeth) (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)) (gl-vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5))))) (gl-end) ;; draw front sides of teeth (gl-begin GL_QUADS) (dotimes (i teeth) (let1 angle (* i 2.0 (/ pi teeth)) (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl-vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl-vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width 0.5)) (gl-vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width 0.5)))) (gl-end) (gl-normal 0.0 0.0 -1.0) ;; draw back face (gl-begin GL_QUAD_STRIP) (dotimes (i (+ teeth 1)) (let1 angle (* i 2.0 (/ pi teeth)) (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (when (< i teeth) (gl-vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))))) (gl-end) ;; draw back sides of teeth (gl-begin GL_QUADS) (dotimes (i teeth) (let1 angle (* i 2.0 (/ pi teeth)) (gl-vertex (* r1 (cos (+ angle (* 3 da)))) (* r1 (sin (+ angle (* 3 da)))) (* width -0.5)) (gl-vertex (* r2 (cos (+ angle (* 2 da)))) (* r2 (sin (+ angle (* 2 da)))) (* width -0.5)) (gl-vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5)) (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)))) (gl-end) ;; draw outward faces of teeth (gl-begin GL_QUAD_STRIP) (dotimes (i teeth) (let* ((angle (* i 2.0 (/ pi teeth))) (u (- (* r2 (cos (+ angle da))) (* r1 (cos angle)))) (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle)))) (len (sqrt (+ (* u u) (* v v)))) (uu (/ u len)) (vv (/ v len))) (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5)) (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5)) (gl-normal v (- u) 0.0) (gl-vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width 0.5)) (gl-vertex (* r2 (cos (+ angle da))) (* r2 (sin (+ angle da))) (* width -0.5)) (gl-normal (cos angle) (sin angle) 0.0) (gl-vertex (* r2 (cos (+ angle da da))) (* r2 (sin (+ angle da da))) (* width 0.5)) (gl-vertex (* r2 (cos (+ angle da da))) (* r2 (sin (+ angle da da))) (* width -0.5)) (gl-normal (- (* r1 (sin (+ angle da da da))) (* r2 (sin (+ angle da da)))) (- (- (* r1 (cos (+ angle da da da))) (* r2 (cos (+ angle da da))))) 0.0) (gl-vertex (* r1 (cos (+ angle da da da))) (* r1 (sin (+ angle da da da))) (* width 0.5)) (gl-vertex (* r1 (cos (+ angle da da da))) (* r1 (sin (+ angle da da da))) (* width -0.5)) (gl-normal (cos angle) (sin angle) 0.0))) (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5)) (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5)) (gl-end) (gl-shade-model GL_SMOOTH) ;; draw inside radius cylinder (gl-begin GL_QUAD_STRIP) (dotimes (i (+ teeth 1)) (let1 angle (* i 2.0 (/ pi teeth)) (gl-normal (- (cos angle)) (- (sin angle)) 0.0) (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)) (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5)))) (gl-end) )) (define *view-rotx* 20.0) (define *view-roty* 30.0) (define *view-rotz* 0.0) (define *gear1* 0) (define *gear2* 0) (define *gear3* 0) (define *angle* 0.0) (define *timer* #f) (define *frames* 0) (define (draw widget . _) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (begin (gl-push-matrix) (gl-rotate *view-rotx* 1.0 0.0 0.0) (gl-rotate *view-roty* 0.0 1.0 0.0) (gl-rotate *view-rotz* 0.0 0.0 1.0) (begin (gl-push-matrix) (gl-translate -3.0 -2.0 0.0) (gl-rotate *angle* 0.0 0.0 1.0) (gl-call-list *gear1*) (gl-pop-matrix)) (begin (gl-push-matrix) (gl-translate 3.1 -2.0 0.0) (gl-rotate (- (* -2.0 *angle*) 9.0) 0.0 0.0 1.0) (gl-call-list *gear2*) (gl-pop-matrix)) (begin (gl-push-matrix) (gl-translate -3.1 4.2 0.0) (gl-rotate (- (* -2.0 *angle*) 25.0) 0.0 0.0 1.0) (gl-call-list *gear3*) (gl-pop-matrix)) (gl-pop-matrix)) (if (gdk-gl-drawable-is-double-buffered gldrawable) (gdk-gl-drawable-swap-buffers gldrawable) (gl-flush)) (gdk-gl-drawable-gl-end gldrawable)) (inc! *frames*) (let1 seconds (g-timer-elapsed *timer*) (when (>= seconds 5.0) (print #`",*frames* in ,seconds seconds = ,(/ *frames* seconds) FPS") (g-timer-reset *timer*) (set! *frames* 0))) #t)) ;; new window size or exposure (define (reshape widget . _) (let* ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget)) (wsize (ref widget 'allocation)) (h (/ (ref wsize 'height) (ref wsize 'width)))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height)) (gl-matrix-mode GL_PROJECTION) (gl-load-identity) (gl-frustum -1.0 1.0 (- h) h 5.0 60.0) (gl-matrix-mode GL_MODELVIEW) (gl-load-identity) (gl-translate 0.0 0.0 -40.0) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** #t)) (define (init widget) (let ((glcontext (gtk-widget-get-gl-context widget)) (gldrawable (gtk-widget-get-gl-drawable widget))) ;;*** OpenGL BEGIN *** (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (gl-light GL_LIGHT0 GL_POSITION '#f32(5.0 5.0 10.0 0.0)) (gl-enable GL_CULL_FACE) (gl-enable GL_LIGHTING) (gl-enable GL_LIGHT0) (gl-enable GL_DEPTH_TEST) ;; make the gears (set! *gear1* (gl-gen-lists 1)) (gl-new-list *gear1* GL_COMPILE) (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.8 0.1 0.0 1.0)) (gear 1.0 4.0 1.0 20 0.7) (gl-end-list) (set! *gear2* (gl-gen-lists 1)) (gl-new-list *gear2* GL_COMPILE) (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.0 0.8 0.2 1.0)) (gear 0.5 2.0 2.0 10 0.7) (gl-end-list) (set! *gear3* (gl-gen-lists 1)) (gl-new-list *gear3* GL_COMPILE) (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.2 0.2 1.0 1.0)) (gear 1.3 2.0 0.5 10 0.7) (gl-end-list) (gl-enable GL_NORMALIZE) (print) (print #`"GL_RENDERER = ,(gl-get-string GL_RENDERER)") (print #`"GL_VERSION = ,(gl-get-string GL_VERSION)") (print #`"GL_VENDOR = ,(gl-get-string GL_VENDOR)") (print #`"GL_EXTENSIONS = ,(gl-get-string GL_EXTENSIONS)") (print) (gdk-gl-drawable-gl-end gldrawable)) ;;*** OpenGL END *** ;; create timer (unless *timer* (set! *timer* (g-timer-new))) (g-timer-start *timer*) )) (define (idle widget) (inc! *angle* 0.5) (if (> *angle* 360) (set! *angle* (fmod *angle* 360))) (gtk-widget-queue-draw widget) #t) (define *idle-id* 0) (define (map widget . _) (when (zero? *idle-id*) (set! *idle-id* (gtk-idle-add-priority GDK_PRIORITY_REDRAW (lambda _ (idle widget))))) #t) (define (unmap widget . _) (unless (zero? *idle-id*) (gtk-idle-remove *idle-id*) (set! *idle-id* 0)) #t) (define (visible widget event) (if (= (ref event 'state) GDK_VISIBILITY_FULLY_OBSCURED) (unless (zero? *idle-id*) (gtk-idle-remove *idle-id*) (set! *idle-id* 0)) (when (zero? *idle-id*) (set! *idle-id* (gtk-idle-add-priority GDK_PRIORITY_REDRAW (lambda _ (idle widget)))))) #t) ;; change view angle, exit upon ESC (define (key widget event) (let ((kv (ref event 'keyval)) (q (lambda () (gtk-widget-queue-draw widget)))) (cond ((= kv GDK_KEY_z) (set! *view-rotz* (fmod (+ *view-rotz* 5.0) 360)) (q)) ((= kv GDK_KEY_Z) (set! *view-rotz* (fmod (- *view-rotz* 5.0) 360)) (q)) ((= kv GDK_KEY_Up) (set! *view-rotx* (fmod (+ *view-rotx* 5.0) 360)) (q)) ((= kv GDK_KEY_Down) (set! *view-rotx* (fmod (- *view-rotx* 5.0) 360)) (q)) ((= kv GDK_KEY_Left) (set! *view-roty* (fmod (+ *view-roty* 5.0) 360)) (q)) ((= kv GDK_KEY_Right) (set! *view-roty* (fmod (- *view-roty* 5.0) 360)) (q)) ((= kv GDK_KEY_Escape) (gtk-main-quit)))) #t) (define (main args) (gtk-init args) (unless (gdk-gl-query-extension) (error "*** OpenGL is not supported.")) ;; ;; Configure OpenGL-capable visual. ;; (let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH GDK_GL_MODE_DOUBLE)) (begin (warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n") (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH))) (error "*** No appropriate OpenGL-capable visual found.") ) ;; ;; Top-level window. ;; (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL) (gtk-window-set-title window "gears") (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit))) (g-signal-connect window "key_press_event" key) (g-signal-connect window "unmap_event" unmap) (let1 vbox (gtk-vbox-new #f 0) (gtk-container-add window vbox) (gtk-widget-show vbox) ;; ;; Drawing area for drawing OpenGL scene. ;; (let1 drawing-area (gtk-drawing-area-new) (gtk-widget-set-size-request drawing-area 300 300) ;; Set OpenGL-capability to the widget. (gtk-widget-set-gl-capability drawing-area glconfig #f #t GDK_GL_RGBA_TYPE) (gtk-box-pack-start vbox drawing-area #t #t 0) (gtk-widget-set-events drawing-area (logior GDK_EXPOSURE_MASK GDK_BUTTON_PRESS_MASK GDK_VISIBILITY_NOTIFY_MASK)) (g-signal-connect drawing-area "realize" init) (g-signal-connect drawing-area "configure_event" reshape) (g-signal-connect drawing-area "expose_event" draw) (g-signal-connect drawing-area "map_event" map) (g-signal-connect drawing-area "unmap_event" unmap) (g-signal-connect drawing-area "visibility_notify_event" visible) (gtk-widget-show drawing-area)) ;; ;; Simple quit button. ;; (let1 button (gtk-button-new-with-label "Quit") (gtk-box-pack-start vbox button #f #f 0) (g-signal-connect button "clicked" (lambda _ (gtk-main-quit))) (gtk-widget-show button)) );vbox (gtk-widget-show window) ) (gtk-main) 0)) gauche-gtk-0.6+git20160927/examples/listener.scm000066400000000000000000000005121300401456300211510ustar00rootroot00000000000000;; sample to use gtk.listener (use gtk) (define (main args) (gtk-init args) (let1 w (gtk-window-new GTK_WINDOW_TOPLEVEL) (g-signal-connect w "destroy" (lambda _ (gtk-main-quit))) (gtk-widget-set-size-request w 100 100) (gtk-widget-show w)) (gtk-scheme-listener-add :finalizer gtk-main-quit) (gtk-main) 0) gauche-gtk-0.6+git20160927/glgd/000077500000000000000000000000001300401456300157215ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/glgd/Makefile.in000066400000000000000000000061161300401456300177720ustar00rootroot00000000000000# # Makefile.in for Gauche-gtk/glgd # # prelude --------------------------------------------- .SUFFIXES: .stub .stub.c : $(GOSH) genstub $< # General info SHELL = @SHELL@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ datarootdir = @datarootdir@ srcdir = @srcdir@ VPATH = $(srcdir) top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ # These may be overridden by make invocators DESTDIR = # These are set by configure # NB: cc and various flags must match the ones used to compile Gauche, # so the make invocator shouldn't casually override them. CC = @CC@ CFLAGS = @DEFS@ @CFLAGS@ @X_CFLAGS@ `gauche-config -I` `gauche-config --so-cflags` $(GTKGL_CFLAGS) LDFLAGS = $(GTKGL_LDFLAGS) @LDFLAGS@ `gauche-config -L` `gauche-config --so-ldflags` LIBS = $(GTKGL_LIBS) @LIBS@ `gauche-config -l` @X_LIBS@ @X_PRE_LIBS@ -lXext -lX11 GOSH = @GOSH@ GAUCHE_CONFIG = @GAUCHE_CONFIG@ INSTALL = @GAUCHE_INSTALL@ OBJEXT = @OBJEXT@ EXEEXT = @EXEEXT@ SOEXT = @SOEXT@ PANGOFT2 = @PANGOFT2_LIB@ # Other definitions # mmc: vvvvvvvvv Added! GTKGL_CFLAGS = `pkg-config --cflags gtkglext-1.0` `pkg-config --cflags freetype2` GTKGL_LDFLAGS = `pkg-config --libs-only-L gtkglext-1.0` GTKGL_LIBS = $(PANGOFT2) `pkg-config --libs-only-l gtkglext-1.0` ARCHFILES = gauche-glgd.$(SOEXT) SCMFILES = glgd.scm SCMFILEDIR = $(top_srcdir)/lib/gtk HEADERS = GAUCHE_PKGINCDIR = $(DESTDIR)@GAUCHE_PKGINCDIR@ GAUCHE_PKGLIBDIR = $(DESTDIR)@GAUCHE_PKGLIBDIR@/gtk GAUCHE_PKGARCHDIR = $(DESTDIR)@GAUCHE_PKGARCHDIR@ # build ----------------------------------------------- TARGET = $(ARCHFILES) OBJS = glgd_head.$(OBJEXT) \ glgdBitfield.$(OBJEXT) \ glgdCam.$(OBJEXT) \ glgdDraw.$(OBJEXT) \ glgdGraph.$(OBJEXT) \ glgdMatrix.$(OBJEXT) \ glgdNode.$(OBJEXT) \ glgdLink.$(OBJEXT) \ glgdQuat.$(OBJEXT) \ glgdStroke.$(OBJEXT) \ glgdTexture.$(OBJEXT) \ gauche-glgd.$(OBJEXT) \ glgdlib.$(OBJEXT) \ glgd_tail.$(OBJEXT) CONFIG_GENERATED = Makefile config.cache config.log config.status GENERATED = glgdlib.c glgdlib.c glgd_head.c glgd_tail.c all : $(TARGET) gauche-glgd.$(SOEXT) : $(OBJS) $(CC) $(LDFLAGS) gauche-glgd.$(SOEXT) $(OBJS) $(LIBS) $(OBJS) : gauche-glgd.h glgdlib.c : glgdlib.stub glgd_head.c glgd_tail.c : $(GAUCHE_CONFIG) --fixup-extension glgd gauche_glgd # tests ----------------------------------------------- check : all @rm -f test.log $(GOSH) -I. -I../src -I../lib test.scm >> test.log # install ---------------------------------------------- install : all $(INSTALL) -m 444 -T $(GAUCHE_PKGINCDIR) $(HEADERS) $(INSTALL) -m 444 -T $(GAUCHE_PKGLIBDIR) -S $(SCMFILEDIR) $(SCMFILES) $(INSTALL) -m 555 -T $(GAUCHE_PKGARCHDIR) $(ARCHFILES) # clean ------------------------------------------------ clean : rm -rf core $(TARGET) $(OBJS) $(GLOBJS) $(GENERATED) *~ test.log so_locations distclean : clean rm -rf $(CONFIG_GENERATED) maintainer-clean : clean rm -rf $(CONFIG_GENERATED) configure gauche-gtk-0.6+git20160927/glgd/README000066400000000000000000000270151300401456300166060ustar00rootroot00000000000000 GLGD - Gauche-gtk extension to draw graphs using OpenGL $Id: README,v 1.3 2007/01/13 01:36:30 maruska Exp $ TABLE OF CONTENTS * INTRODUCTION * COMPILATION * CONCEPTS * API REFERENCE INTRODUCTION ------------ GLGD (GL graph draw) is a set of classes which enables Gauche-gtk applications to draw a graph in a Gtk widget. The application constructs a graph by creating nodes and defining directional links between them. Graph can form general directed graph---cycles and shared-subgraphs are allowed (though the rendering of such structure isn't well implemented in the current version). The current version renders the graph in the 'forest'--- a set of trees. If it encounters shared substructure or cycle, it indicates the relation by differently colored links. In the future version a more flexible layout will be supported, including 'free layout' where the user can place node freely. The current API is provisonal. It is likely to be changed after a few applications are written. COMPILATION ----------- GLGD uses GtkGLArea to display a graph. In order to display multilingual text, it also uses Pango with FreeType2 backend. To compile GLGD with Pango support, configure Gauche-gtk as follows: $ ./configure --enable-glgd-pango It implies --enable-gtkgl as well. If you have some problem using pango and can live with ASCII-only world, you can compile GLGD without pango: $ ./configure --enable-glgd CONCEPTS -------- Graph classes ............. GLGD provides four classes to construct a graph. [class] A graph itself. It holds all the structures, and responsible to layout and render the graph on the specified window. It also provides several callback facilities for applications to define user interactions of the graph. [class] A node of a graph. [class] A link between nodes. [class] An auxiliary class to represent a set of links. Links from a parent to childrens, for example, can be put in a link-list so that it can be rendered as the one link begins from a parent and branches to children. Typical steps to construct a graph are as follow: - create a . - create s, and adds them to the graph. - create s, adds them to the graph. - create s, connects nodes with them, and adds them to the graph and link-lists. You can find a few example scripts under the Gauche-gtk/examples/glgd directory. When a graph is destroyed, nodes, links and link-lists the graph owned are destroyed, too. You can also 'flush' the contents of the graph, i.e. keeping a graph instance but destroying all nodes, links and link-lists, in order to rebuild a graph. A higher-level API on top of these primitive graphs is planned to be created. Flags and attributes .................... Each object may have number of flags and attributes. Each flag or attribute is a boolean value. Flags are used to control a behavior of instances of individual classes, and mainly used internally; applications are not supposed to use them. *-flags-set API can be used to set, reset or toggle flag(s) of an object. Attributes can be used by applications to group object(s) in the graph. For example, the application can group some nodes and render them in a specific color. Attributes can be manipulated and queried individually, by *-attribute-{clear,set,reset,is-set} APIs and using attribute index. Currently, a graph can have up to 256 attributes; attribute indexes between 0 to 254 are available (255 is reserved). This limitation may be removed later. API REFERENCE ------------- Common constants ................ [constant] GLGD_FLAGOP_CLEAR [constant] GLGD_FLAGOP_SET [constant] GLGD_FLAGOP_TOGGLE Specifies flag operations. Procedures that manipulate bitflags take bitmask ('mask') and flag operation ('flag-op') arguments. If flag-op is GLGD_FLAGOP_CLEAR, bits given to 'mask' are cleared. If flag-op is GLGD_FLAGOP_SET, bits of 'mask' are set. And if flag-op is GLGD_FLAGOP_TOGGLE, bits of 'mask' are inverted. [constant] GLGD_ATTR_FORCEVISIBLE A reserved attribute index. ........... [constant] GLGDNODE_FLAG_HILITE [constant] GLGDNODE_FLAG_DIM [constant] GLGDNODE_FLAG_SELECTED Pre-defined flags for nodes. [procedure] glgd-node-create Creates a new node. [procedure] glgd-node-destroy node Explicitly destroys a node. If the node is in the linked chain of a graph, subsequent nodes are all destroyed. Usually you don't need to call this, since glgd-graph-fini and glgd-graph-destroy call this. [procedure] glgd-node-label-set node label [procedure] glgd-node-label-get node Sets/gets node label (string), which is displayed on the screen. Label must be utf-8 encoded. [procedure] glgd-node-data-set node data [procedure] glgd-node-data-get node Sets/gets an opaque data to the node. If you call glgd-node-data-get without setting data, #f is returned. [procedure] glgd-node-id-set node id [procedure] glgd-node-id-get node Sets/gets an node id (integer). Node id is used to identify a node within a graph. The program needs to ensure every id in a graph is unique. [procedure] glgd-node-info-set node label id Convenience function to sets both label and id. [procedure] glgd-node-flags-set node mask flag-op Mainuplates flags of the node. [procedure] glgd-node-is-selected node Returns #t if node is selected, #f otherwise. [procedure] glgd-node-color-default r g b a Sets default color of the node which will be created. Each RGBA value must be in the range between 0.0 and 1.0. [procedure] glgd-node-color-set node r g b a Sets the color of the specified node. Each RGBA value must be in the range between 0.0 and 1.0. [procedure] glgd-node-attribute-clear node [procedure] glgd-node-attribute-set node attr-index [procedure] glgd-node-attribute-reset node attr-index [procedure] glgd-node-attribute-is-set node attr-index Manipulates node attributes. ........... [procedure] glgd-link-create Creates a new instance. [procedure] glgd-link-destroy link Explicitly destroys a link. Usually you don't need to call this, since links owned by a graph will be destroyed with the graph. [procedure] glgd-link-set link src-node dst-node Sets a link from src-node to dst-node. [procedure] glgd-link-flags-set link mask flag-op Manipulate link flags. ................ [procedure] glgd-link-list-create Creates a new instance. [procedure] glgd-link-list-destroy link-list Explicitly destroys a link-list. Usually you don't need to call this, since link-lists owned by a graph will be destroyed with the graph. [procedure] glgd-link-list-flags-set link-list mask flag-op Manipulate link-list flags. ............ [constant] GLGDGRAPH_FN_MOUSE_LEFT [constant] GLGDGRAPH_FN_MOUSE_MIDDLE [constant] GLGDGRAPH_FN_MOUSE_RIGHT [constant] GLGDGRAPH_FN_MOUSE_SCROLL [constant] GLGDGRAPH_FN_MOUSE_HOVER [constant] GLGDGRAPH_FN_KEY [constant] GLGDGRAPH_FN_PRERENDER These values are used to specify a callback function type in glgd-graph-callback-set. [constant] GLGDGRAPH_FLAG_CTRLHELD [constant] GLGDGRAPH_FLAG_ESCPRESSED [constant] GLGDGRAPH_FLAG_PANGOBOLD Predefined flags that are used internally. [procedure] glgd-graph-create Creates and initializes a new instance, and returns it. [procedure] glgd-graph-destroy graph Explicitly destroys instance and frees related resources. [procedure] glgd-graph-init graph Initializes instance, so that it can be used to add nodes/links and be rendered. If you want to re-initialize graph, you must call glgd-graph-fini first. [procedure] glgd-graph-fini graph Clears instance's internal structure, such as node and link lists. All nodes and links associated to the graph are destroyed. [procedure] glgd-graph-draw graph Renders graph. The destination window should have been specified by glgd-graph-connect. Typically you call this procedure when you need to redisplay the graph, such as in the callback of expose_event. [procedure] glgd-graph-frame graph Resets graph's viewport so that all the nodes can be visible. [procedure] glgd-graph-invalidate graph Calls gdk_window_invalidate_rect on the window attached to graph, so that the expose_event callback would be emitted to trigger redrawing of the graph. [procedure] glgd-graph-reshape graph Notify the graph that the dimension of the drawing area is changed. The actual dimension will be computed when the graph is rendered in the next time. [procedure] glgd-graph-connect graph drawing-area Drawing-area should be . Attaches the graph to the drawing area. The graph will take events from the drawing area, and will be rendered into it. [procedure] glgd-graph-translate graph x y Moves graph contents by [x, y], both in real number. [procedure] glgd-graph-center graph Adjusts graph contents so that it is placed in the center of the viewport. [procedure] glgd-graph-auto-organize graph x y This function re-aligns nodes and links. X and y are real numbers, specifying the left-top corner of the graph. [procedure] glgd-graph-node-by-id graph id Returns a node in the graph which has an id. See also glgd-node-id-set. [procedure] glgd-graph-node-select-count graph Returns a number of nodes that are selectec currently. [procedure] glgd-graph-node-count graph Returns a number of nodes the graph has. [procedure] glgd-graph-node-add graph node Adds a node to the graph. Node must not belong to any graph before. [procedure] glgd-graph-node-list-flag graph flag-mask flag-op Manipulates flags of all nodes in the graph. [procedure] glgd-graph-link-list-add graph link-list Adds a link-list to the graph. The link-list must not belong to any graph before. [procedure] glgd-graph-link-add graph link-list link Adds a link to the link-list in the graph. The link must not belong to any graph before. [procedure] glgd-graph-link-index graph link Returns the index number of the link in the graph. Returns -1 if the link is not in the graph. [procedure] glgd-graph-link-by-index graph index Returns the link specified by the index in the graph. [procedure] glgd-graph-callback-set graph type proc Sets a callback procedure proc to the graph. The type argument takes one of the value of GLGDGRAPH_FN_* constants. The procedure is called with four arguments, a object, a object on which the mouse cursor is on, a object on which the mouse cursor is on, and a object. [procedure] glgd-graph-flags-set graph flag-mask flag-op Manipulates flags of the graph. [procedure] glgd-graph-dim-set graph w h Sets graph's dimensions. [procedure] glgd-graph-margin-set graph margin [procedure] glgd-graph-margin-get graph Sets and gets graph's margin. [procedure] glgd-graph-line-color-set graph r g b a Sets the color in which lines are drawn in the graph. [procedure] glgd-graph-attribute-clear graph [procedure] glgd-graph-attribute-set graph attr-index [procedure] glgd-graph-attribute-toggle graph attr-index [procedure] glgd-graph-attribute-reset graph attr-index [procedure] glgd-graph-attribute-is-set graph attr-index Manipulates graph attributes. [procedure] glgd-verbosity verbosity Sets the verbose level (nonnegative integer). When verbosity is greater than zero, glgd prints out various debug information. gauche-gtk-0.6+git20160927/glgd/README.eucjp000066400000000000000000000265041300401456300177150ustar00rootroot00000000000000 GLGD - OpenGL¤òÍѤ¤¤Æ¥°¥é¥Õ¤òÉÁ¤¯Gauche-gtk¤Î³ÈÄ¥ $Id: README.eucjp,v 1.3 2007/01/13 01:36:30 maruska Exp $ Ìܼ¡ * ¥¤¥ó¥È¥í¥À¥¯¥·¥ç¥ó * ¥³¥ó¥Ñ¥¤¥ë * ³µÇ° * API¥ê¥Õ¥¡¥ì¥ó¥¹ ¥¤¥ó¥È¥í¥À¥¯¥·¥ç¥ó ------------------ GLGD (GL graph draw)¤ÏGauche-gtk¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤ÇGtk widget Æâ¤Ë¥°¥é¥Õ¤òÉÁ²è¤¹¤ë¤¿¤á¤Î¥¯¥é¥¹¤Î¥»¥Ã¥È¤Ç¤¹¡£ ¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤Ï¡¢¥°¥é¥Õ¤Î¥Î¡¼¥É¤òºîÀ®¤·¡¢¥Î¡¼¥É´Ö¤ÎÍ­¸þ¥ê¥ó¥¯¤ò ÄêµÁ¤¹¤ë¤³¤È¤Ç¥°¥é¥Õ¤ò¹½ÃÛ¤·¤Þ¤¹¡£¥°¥é¥Õ¤Ï°ìÈÌŪ¤ÊÍ­¸þ¥°¥é¥Õ¤Ë ¤Ê¤ê¤Þ¤¹¡£½Û´Ä¤ä¶¦Í­¹½Â¤¤¬¤¢¤Ã¤Æ¤â¹½¤¤¤Þ¤»¤ó¡£(⤷¡¢¸½ºß¤Î ¥Ð¡¼¥¸¥ç¥ó¤Ç¤Ï¤½¤Î¤è¤¦¤Ê¹½Â¤¤Îɽ¼¨¤Ï¤¢¤Þ¤êåºÎï¤Ç¤Ï¤¢¤ê¤Þ¤»¤ó)¡£ ¸½ºß¤Î¥Ð¡¼¥¸¥ç¥ó¤Ç¤Ï¡¢¥°¥é¥Õ¤ò¡Ö¿¹¡×¡¢¤Ä¤Þ¤êÌڤΥ»¥Ã¥È¤Ç¤¢¤ë¤È ¤·¤ÆÉÁ²è¤·¤Þ¤¹¡£ÅÓÃæ¤Ç½Û´Ä¹½Â¤¤ä¶¦Í­¹½Â¤¤Ë½Ð²ñ¤¦¤È¡¢¤½¤ÎÉôʬ¤Î ¥ê¥ó¥¯¤ò¿§¤òÊѤ¨¤Æɽ¼¨¤·¤Þ¤¹¡£¾­Íè¤Î¥Ð¡¼¥¸¥ç¥ó¤Ç¤Ï¡¢¤è¤ê½ÀÆð¤Ê ¥ì¥¤¥¢¥¦¥È¥¢¥ë¥´¥ê¥º¥à¤¬¥µ¥Ý¡¼¥È¤µ¤ì¤ë¤Ç¤·¤ç¤¦¡£ ¸½ºß¤ÎAPI¤Ï»ÃÄêŪ¤Ê¤â¤Î¤Ç¤¹¡£¤¤¤¯¤Ä¤«¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤ò½ñ¤¤¤¿¸å¤Ç¡¢ ÂçÉý¤Ë¸«Ä¾¤µ¤ì¤ë²ÄǽÀ­¤¬¤¢¤ê¤Þ¤¹¡£ ¥³¥ó¥Ñ¥¤¥ë ---------- GLGD¤ÏÉÁ²è¤ËGtkGLArea¤ò»È¤¤¤Þ¤¹¡£¤Þ¤¿¡¢Â¿¹ñ¸ì¥Æ¥­¥¹¥È¤òɽ¼¨¤¹¤ë¤¿¤á¤Ë Pango¤ÎFreeType2¥Ð¥Ã¥¯¥¨¥ó¥É¤ò»ÈÍѤ·¤Æ¤¤¤Þ¤¹¡£ GLGD¤òPango¥µ¥Ý¡¼¥È¹þ¤ß¤Ç¥³¥ó¥Ñ¥¤¥ë¤¹¤ë¤Ë¤Ï¡¢Gauche-gtk¤ò¼¡¤Î¤è¤¦¤Ë configure¤·¤Æ¤¯¤À¤µ¤¤¡£ $ ./configure --enable-glgd-pango p ¤³¤¦¤¹¤ë¤È¡¢--enable-gtkgl¤â¼«Æ°Åª¤ËÍ­¸ú¤Ë¤Ê¤ê¤Þ¤¹¡£ ¤â¤·Pango¤¬¤¦¤Þ¤¯Æ°¤«¤º¡¢ASCIIʸ»úÎó¤À¤±¤Ç»î¤·¤¿¤¤¾ì¹ç¤Ï¡¢ ¼¡¤Î¤è¤¦¤Ëconfigure¤·¤Þ¤¹¡£ $ ./configure --enable-glgd ³µÇ° ---- Graph´Ø·¸¤Î¥¯¥é¥¹ ................. GLGD¤Ï¡¢¥°¥é¥Õ¤Î¹½ÃۤΤ¿¤á¤Ë°Ê²¼¤Î4¤Ä¤Î¥¯¥é¥¹¤òÄ󶡤·¤Þ¤¹¡£ [class] ¥°¥é¥ÕËÜÂΤǤ¹¡£¥°¥é¥Õ¤Ë´Ø·¸¤¹¤ë¾¤Î¹½Â¤¤ò½êÍ­¤·¡¢Í¿¤¨¤é¤ì¤¿¥¦¥£¥ó¥É¥¦¤Ë ¥°¥é¥Õ¤ò¥ì¥¤¥¢¥¦¥È¤·¤Æɽ¼¨¤·¤Þ¤¹¡£¤Þ¤¿¡¢¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤¬¥°¥é¥Õ¤Ë ÂФ¹¤ë¥æ¡¼¥¶ÆþÎϤò½èÍý¤Ç¤­¤ë¤è¤¦¤Ê¥³¡¼¥ë¥Ð¥Ã¥¯µ¡¹½¤òÄ󶡤·¤Þ¤¹¡£ [class] ¥°¥é¥Õ¤Î¥Î¡¼¥É¤Ç¤¹¡£ [class] ¥Î¡¼¥É´Ö¤Î¥ê¥ó¥¯¤Ç¤¹¡£ [class] ¥ê¥ó¥¯¤Î¥»¥Ã¥È¤òɽ¸½¤¹¤ëÊä½õ¥¯¥é¥¹¤Ç¤¹¡£Î㤨¤Ð¿Æ¤«¤éÊ£¿ô¤Î»Ò¤Ø¤È ¥ê¥ó¥¯¤¬Ä¥¤é¤ì¤Æ¤¤¤ë¾ì¹ç¡¢¤½¤ì¤é¤Î¥ê¥ó¥¯¤òlink-list¤Ë¤Þ¤È¤á¤Æ¤ª¤±¤Ð¡¢ parent¤«¤é¤Ï°ìËܤΥê¥ó¥¯¤¬¥¹¥¿¡¼¥È¤·¡¢¤½¤ì¤¬ÅÓÃæ¤Ç»Þ¤ï¤«¤ì¤·¤Æ »Ò¤Ø¤ÈÀܳ¤µ¤ì¤ë¤è¤¦¤Ëɽ¼¨¤µ¤ì¤Þ¤¹¡£ ¥°¥é¥Õ¤ò¹½ÃÛ¤¹¤ëɸ½àŪ¤Ê¼ê½ç¤Ï°Ê²¼¤ÎÄ̤ê¤Ç¤¹¡£ - ¥¤¥ó¥¹¥¿¥ó¥¹¤òºî¤ë - ¥¤¥ó¥¹¥¿¥ó¥¹¤òºî¤ê¡¢¥°¥é¥Õ¤ËÄɲ乤롣 - ¥¤¥ó¥¹¥¿¥ó¥¹¤òºî¤ê¡¢¥°¥é¥Õ¤ËÄɲ乤롣 - ¥¤¥ó¥¹¥¿¥ó¥¹¤òºî¤ê¡¢¥Î¡¼¥É¤òÀܳ¤·¡¢ ¥ê¥ó¥¯¤ò¥ê¥ó¥¯¥ê¥¹¥È¤È¥°¥é¥Õ¤ËÄɲ乤롣 Gauche-gtk/examples/glgd¤Î²¼¤Ë¤¤¤¯¤Ä¤«Î㤬¤¢¤ê¤Þ¤¹¡£ ¥°¥é¥Õ¤¬ÇË´þ¤µ¤ì¤ë¤È¤­¤Ë¡¢¤½¤ì¤Ë½êÍ­¤µ¤ì¤Æ¤¤¤ë¥Î¡¼¥É¡¢¥ê¥ó¥¯¡¢¥ê¥ó¥¯¥ê¥¹¥È¤â ÇË´þ¤µ¤ì¤Þ¤¹¡£¤Þ¤¿¡¢¥°¥é¥Õ¥ª¥Ö¥¸¥§¥¯¥È¤ÏÊÝ»ý¤·¤Ä¤ÄÃæ¿È¤À¤±¤ò¼Î¤Æ¤Æ¡¢¤â¤¦°ìÅÙ ¥°¥é¥Õ¤ò¹½ÃÛ¤¹¤ë¤³¤È¤â¤Ç¤­¤Þ¤¹¡£ ¾­Íè¤Ï¡¢¤³¤ì¤é¤ÎÄã¥ì¥Ù¥ë¤Î¥¯¥é¥¹API¤Î¾å¤Ë¡¢¤è¤ê¹â¥ì¥Ù¥ë¤ÎAPI¤¬ Ä󶡤µ¤ì¤ëͽÄê¤Ç¤¹¡£ ¥Õ¥é¥°¤È°À­ ............ ³Æ¥ª¥Ö¥¸¥§¥¯¥È¤Ï¤¤¤¯¤Ä¤â¤Î¥Õ¥é¥°¤È°À­¤ò»ý¤Á¤Þ¤¹¡£¥Õ¥é¥°¤È°À­¤Ï ¤È¤â¤Ë¿¿µ¶ÃͤǤ¹¡£ ¥Õ¥é¥°¤Ï³Æ¥¯¥é¥¹¤Î³Æ¥¤¥ó¥¹¥¿¥ó¥¹¤Î¤Õ¤ë¤Þ¤¤¤òÀ©¸æ¤¹¤ë¤¿¤á¤Ë¡¢ÆâÉôŪ¤Ë ÍѤ¤¤é¤ì¤Æ¤¤¤Þ¤¹¡£¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤ÏÄ̾ïľÀܥե饰¤ò¿¨¤ë¤³¤È¤Ï¤¢¤ê¤Þ¤»¤ó¡£ *-flags-set API´Ø¿ô¤Ë¤è¤Ã¤Æ¡¢¥ª¥Ö¥¸¥§¥¯¥È¤Î¥Õ¥é¥°¤ò¥»¥Ã¥È¤·¤¿¤ê¡¢ ¥ê¥»¥Ã¥È¤·¤¿¤ê¡¢¥È¥°¥ë¤·¤¿¤ê¤¹¤ë¤³¤È¤¬¤Ç¤­¤Þ¤¹¡£ °À­¤Ï¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤Ë¤è¤Ã¤Æ¡¢¥°¥é¥ÕÃæ¤Î¥ª¥Ö¥¸¥§¥¯¥È¤ò¥°¥ë¡¼¥×²½ ¤¹¤ë¤Î¤Ë»È¤¨¤Þ¤¹¡£Î㤨¤Ð¡¢¥Î¡¼¥É¤Î¥°¥ë¡¼¥×¤òºî¤Ã¤Æ¤ª¤¤¤Æ¡¢¤½¤ì¤é¤ò ÆÃÄê¤Î¿§¤Çɽ¼¨¤¹¤ë¤È¤¤¤¦¶ñ¹ç¤Ç¤¹¡£Â°À­¤Ï *-attribute-{clear,set,reset,is-set} API¤Ë¤è¤Ã¤Æ¡¢³Æ°À­¤´¤È¤ËÃͤòÄ´¤Ù¤¿¤êÁàºî¤¹¤ë¤³¤È¤¬¤Ç¤­¤Þ¤¹¡£Â°À­¤Ï ¥¤¥ó¥Ç¥Ã¥¯¥¹ÃͤǻØÄꤵ¤ì¤Þ¤¹¡£º£¤Î¤È¤³¤í¡¢0¤«¤é255¤Þ¤Ç¤Î°À­¥¤¥ó¥Ç¥Ã¥¯¥¹¤¬ »È¤¨¤Þ¤¹(⤷¡¢¥·¥¹¥Æ¥à¤Ï°À­255¤òͽÌ󤷤Ƥ¤¤Þ¤¹)¡£¾­Íè¤Ï¤³¤Î¿ô¤ÎÀ©¸Â¤Ï ̵¤¯¤Ê¤ë¤Ç¤·¤ç¤¦¡£ API¥ê¥Õ¥¡¥ì¥ó¥¹ --------------- ¶¦Ä̤ÎÄê¿ô .......... [constant] GLGD_FLAGOP_CLEAR [constant] GLGD_FLAGOP_SET [constant] GLGD_FLAGOP_TOGGLE ¥Õ¥é¥°Áàºî¤ò»ØÄꤷ¤Þ¤¹¡£¥Õ¥é¥°¤òÁàºî¤¹¤ë¼ê³¤­¤Ï¡¢À°¿ô¤Ë¤è¤ë¥Ó¥Ã¥È¥Þ¥¹¥¯ (mask)¤È¥Õ¥é¥°Áàºî(flag-op)¤ò°ú¿ô¤Ë¤È¤ê¤Þ¤¹¡£flag-op¤¬GLGD_FLAGOP_CLEAR ¤Ç¤¢¤ì¤Ð¡¢mask¤Ç»ØÄꤵ¤ì¤¿¥Ó¥Ã¥È¤¬¥¯¥ê¥¢¤µ¤ì¤Þ¤¹¡£flag-op¤¬ GLGD_FLAGOP_SET¤Ç¤¢¤ì¤Ð¡¢mask¤Î¥Ó¥Ã¥È¤¬¥»¥Ã¥È¤µ¤ì¤Þ¤¹¡£¤½¤·¤Æ¡¢ flag-op¤¬GLGD_FLAGOP_TOGGLE¤Ç¤¢¤ì¤Ð¡¢mask¤Î¥Ó¥Ã¥È¤Ïȿž¤µ¤ì¤Þ¤¹¡£ [constant] GLGD_ATTR_FORCEVISIBLE ¥·¥¹¥Æ¥à¤ÇͽÌ󤵤ì¤Æ¤¤¤ë°À­¥¤¥ó¥Ç¥Ã¥¯¥¹¤Ç¤¹¡£ ........... [constant] GLGDNODE_FLAG_HILITE [constant] GLGDNODE_FLAG_DIM [constant] GLGDNODE_FLAG_SELECTED ¥Î¡¼¥É¤ËÂФ¹¤ë´ûÄê¤Î¥Õ¥é¥°¤Ç¤¹¡£ [procedure] glgd-node-create ¿·¤·¤¤¥Î¡¼¥É¤òºîÀ®¤·¤Þ¤¹¡£ [procedure] glgd-node-destroy node ÌÀ¼¨Åª¤Ë¥Î¡¼¥É¤òÇË´þ¤·¤Þ¤¹¡£Ä̾ï¤Ï¡¢glgd-graph-fini¤äglgd-graph-destroy ¤¬¥°¥é¥Õ¤Î½êÍ­¤¹¤ë¥Î¡¼¥É¤òÇË´þ¤¹¤ë¤¿¤á¡¢¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤¬¤³¤ì¤òľÀÜ ¸Æ¤ÖɬÍפϤ¢¤ê¤Þ¤»¤ó¡£ [procedure] glgd-node-label-set node label [procedure] glgd-node-label-get node ¥Î¡¼¥É¤Î¥é¥Ù¥ë(ʸ»úÎó)¤òset/get¤·¤Þ¤¹¡£¤³¤Îʸ»úÎ󤬲èÌ̤Ëɽ¼¨¤µ¤ì¤Þ¤¹¡£ ʸ»úÎó¤Ïutf-8¤Ç¥¨¥ó¥³¡¼¥É¤µ¤ì¤Æ¤¤¤Ê¤±¤ì¤Ð¤Ê¤ê¤Þ¤»¤ó¡£ [procedure] glgd-node-data-set node data [procedure] glgd-node-data-get node ¥Î¡¼¥É¤ËÂФ·¤ÆǤ°Õ¤Î¥Ç¡¼¥¿¤ò·ë¤Ó¤Ä¤±¤Þ¤¹¡£¥Ç¡¼¥¿¤¬ÀßÄꤵ¤ì¤Æ¤¤¤Ê¤¤¥Î¡¼¥É¤Ë ÂФ·¤Æglgd-node-data-get¤ò¸Æ¤Ö¤È#f¤¬ÊÖ¤ê¤Þ¤¹¡£ [procedure] glgd-node-id-set node id [procedure] glgd-node-id-get node ¥Î¡¼¥É¤Îid(À°¿ô)¤òset/get¤·¤Þ¤¹¡£¥Î¡¼¥Éid¤Ï¥°¥é¥ÕÃæ¤Ç¥Î¡¼¥É¤ò°ì°Õ¤Ë »ØÄꤹ¤ë¤¿¤á¤Ë»È¤ï¤ì¤Þ¤¹¡£¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤Ï¡¢¥Î¡¼¥É¤¬¥°¥é¥ÕÃæ¤Ç °ì°Õ¤Îid¤ò»ý¤Ä¤è¤¦¤ËÀßÄꤷ¤Ê¤±¤ì¤Ð¤Ê¤ê¤Þ¤»¤ó¡£ [procedure] glgd-node-info-set node label id ¥Î¡¼¥É¤Î¥é¥Ù¥ë¤Èid¤òÀßÄꤹ¤ëÊØÍø¤Ê´Ø¿ô¤Ç¤¹¡£ [procedure] glgd-node-flags-set node mask flag-op ¥Î¡¼¥É¤Î¥Õ¥é¥°¤òÁàºî¤·¤Þ¤¹¡£ [procedure] glgd-node-is-selected node ¥Î¡¼¥É¤¬¥°¥é¥ÕÃæ¤ÇÁªÂò¾õÂ֤ˤ¢¤ë¤È¤­#t¤ò¡¢¤½¤¦¤Ç¤Ê¤±¤ì¤Ð#f¤òÊÖ¤·¤Þ¤¹¡£ [procedure] glgd-node-color-default r g b a ¥Î¡¼¥É¤Î¥Ç¥Õ¥©¥ë¥È¥«¥é¡¼¤òÀßÄꤷ¤Þ¤¹¡£³ÆRGBAÃͤÏ0.0¤«¤é1.0¤Þ¤Ç¤Î ¼Â¿ôÃͤǤ¹¡£ [procedure] glgd-node-color-set node r g b a ¥Î¡¼¥Énode¤Î¥«¥é¡¼¤òÀßÄꤷ¤Þ¤¹¡£³ÆRGBAÃͤÏ0.0¤«¤é1.0¤Þ¤Ç¤Î ¼Â¿ôÃͤǤ¹¡£ [procedure] glgd-node-attribute-clear node [procedure] glgd-node-attribute-set node attr-index [procedure] glgd-node-attribute-reset node attr-index [procedure] glgd-node-attribute-is-set node attr-index ¥Î¡¼¥É¤Î°À­ÃͤòÁàºî¤·¤Þ¤¹¡£ ........... [procedure] glgd-link-create ¿·¤·¤¤¥¤¥ó¥¹¥¿¥ó¥¹¤òºîÀ®¤·¤Þ¤¹¡£ [procedure] glgd-link-destroy link ÌÀ¼¨Åª¤Ë¥ê¥ó¥¯¤òÇË´þ¤·¤Þ¤¹¡£Ä̾ï¤Ï¡¢¥°¥é¥Õ¤¬¥ê¥ó¥¯¤Î´ÉÍý¤ò¹Ô¤¦¤Î¤Ç¡¢ ¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤Ï¤³¤Î´Ø¿ô¤òľÀܸƤÖɬÍפϤ¢¤ê¤Þ¤»¤ó¡£ [procedure] glgd-link-set link src-node dst-node ¥ê¥ó¥¯¤ò¥Î¡¼¥Ésrc-node¤«¤é¥Î¡¼¥Édst-node¤ØÀßÄꤷ¤Þ¤¹¡£ [procedure] glgd-link-flags-set link mask flag-op ¥ê¥ó¥¯¤Î¥Õ¥é¥°¤òÁàºî¤·¤Þ¤¹¡£ ................ [procedure] glgd-link-list-create ¿·¤·¤¤¥¤¥ó¥¹¥¿¥ó¥¹¤òºîÀ®¤·¤Þ¤¹¡£ [procedure] glgd-link-list-destroy link-list ¥¤¥ó¥¹¥¿¥ó¥¹¤òÇË´þ¤·¤Þ¤¹¡£Ä̾ï¤Ï¡¢¥°¥é¥Õ¤¬¥ê¥ó¥¯¥ê¥¹¥È¤Î ´ÉÍý¤ò¹Ô¤¦¤Î¤Ç¡¢¥¢¥×¥ê¥±¡¼¥·¥ç¥ó¤Ï¤³¤Î´Ø¿ô¤òľÀܸƤÖɬÍפϤ¢¤ê¤Þ¤»¤ó¡£ [procedure] glgd-link-list-flags-set link-list mask flag-op ¥ê¥ó¥¯¥ê¥¹¥È¤Î¥Õ¥é¥°¤òÁàºî¤·¤Þ¤¹¡£ ............ [constant] GLGDGRAPH_FN_MOUSE_LEFT [constant] GLGDGRAPH_FN_MOUSE_MIDDLE [constant] GLGDGRAPH_FN_MOUSE_RIGHT [constant] GLGDGRAPH_FN_MOUSE_SCROLL [constant] GLGDGRAPH_FN_MOUSE_HOVER [constant] GLGDGRAPH_FN_KEY [constant] GLGDGRAPH_FN_PRERENDER ¤³¤ì¤é¤ÎÃͤϡ¢¥³¡¼¥ë¥Ð¥Ã¥¯´Ø¿ô¤Î¥¿¥¤¥×¤ò»ØÄꤹ¤ë¤¿¤á¤Ë glgd-graph-callback-set¸Æ¤Ó½Ð¤·¤ÇÍѤ¤¤é¤ì¤Þ¤¹¡£ [constant] GLGDGRAPH_FLAG_CTRLHELD [constant] GLGDGRAPH_FLAG_ESCPRESSED [constant] GLGDGRAPH_FLAG_PANGOBOLD ÆâÉô¤Ç»È¤ï¤ì¤ë´ûÄê¤Î¥Õ¥é¥°ÃͤǤ¹¡£ [procedure] glgd-graph-create ¿·¤¿¤Ê¥ª¥Ö¥¸¥§¥¯¥È¤òºîÀ®¤·¡¢½é´ü²½¤·¤ÆÊÖ¤·¤Þ¤¹¡£ [procedure] glgd-graph-destroy graph ÌÀ¼¨Åª¤Ë¥ª¥Ö¥¸¥§¥¯¥È¤òÇË´þ¤·¤Þ¤¹¡£¥°¥é¥Õ¤¬ÊÝ»ý¤¹¤ë ¥Î¡¼¥É¤ä¥ê¥ó¥¯Åù¤âÇË´þ¤µ¤ì¤Þ¤¹¡£ [procedure] glgd-graph-init graph ¥°¥é¥Õ¤ò½é´ü²½¤·¤Þ¤¹¡£½é´ü²½¸å¤Ë¡¢¿·¤¿¤Ë¥Î¡¼¥É¤ä¥ê¥ó¥¯¤òÄɲä·¤Æ ¤æ¤¯¤³¤È¤¬¤Ç¤­¤Þ¤¹¡£´û¸¤Î¥°¥é¥Õ¥ª¥Ö¥¸¥§¥¯¥È¤ËÂФ·¤Æ¤½¤ÎÆâÍƤò°ìö ¾Ãµî¤·¡¢¥°¥é¥Õ¤ò¿·¤¿¤Ë¹½ÃÛ¤¹¤ë¤Ë¤Ï¡¢¤Þ¤ºglgd-graph-fini¤ò¸Æ¤ó¤Ç¤«¤é glgd-graph-init¤ò¸Æ¤Ó¤Þ¤¹¡£ [procedure] glgd-graph-fini graph ¥°¥é¥Õ¤ÎÆâÍƤò¶õ¤Ë¤·¤Þ¤¹¡£¥°¥é¥Õ¤ËÊÝ»ý¤µ¤ì¤Æ¤¤¤¿¥Î¡¼¥É¤ä¥ê¥ó¥¯¤Ï ÇË´þ¤µ¤ì¤Þ¤¹¡£¤³¤Î¸å¡¢glgd-graph-init¤ò¸Æ¤Ö¤È¡¢ºÆ¤Ó¤½¤Î¥°¥é¥Õ¤Ë ¥Î¡¼¥É¤ä¥ê¥ó¥¯¤òÄɲ䷤Ƥ椯¤³¤È¤¬¤Ç¤­¤Þ¤¹¡£ [procedure] glgd-graph-draw graph ¥°¥é¥Õ¤òɽ¼¨¤·¤Þ¤¹¡£É½¼¨¤µ¤ì¤ë¥¦¥£¥ó¥É¥¦¤Ï¡¢glgd-graph-connect¤Ç Àܳ¤µ¤ì¤¿¤â¤Î¤Ç¤¹¡£ Ä̾ï¤Ï¡¢expose_event¤Î¥³¡¼¥ë¥Ð¥Ã¥¯Åù¡¢¥°¥é¥Õ¤ÎºÆɽ¼¨¤¬É¬Íפʲսê¤Ç ¤³¤Î´Ø¿ô¤ò¸Æ¤Ó¤Þ¤¹¡£ [procedure] glgd-graph-frame graph ¥°¥é¥Õ¤Î¥Ó¥å¡¼¥Ý¡¼¥È¤ò¡¢Á´¤Æ¤Î¥Î¡¼¥É¤¬¸«¤¨¤ë¤è¤¦¤Ë¥»¥Ã¥È¤·¤Þ¤¹¡£ [procedure] glgd-graph-invalidate graph ¥°¥é¥Õ¤ËÀܳ¤µ¤ì¤¿¥¦¥£¥ó¥É¥¦¤ËÂФ·¤Ægdk_window_invalidate_rect ¤ò¸Æ¤Ó¤Þ¤¹¡£¤³¤ì¤Ïexpose_event¤òȯÀ¸¤µ¤»¡¢·ë²ÌŪ¤Ë¥°¥é¥Õ¤ÎºÆÉÁ²è¤ò ¥È¥ê¥¬¤·¤Þ¤¹¡£ [procedure] glgd-graph-reshape graph ¥°¥é¥Õ¤Ë¡¢ÉÁ²è¥¨¥ê¥¢¤ÎÂ礭¤µ¤¬ÊѲ½¤·¤¿¤³¤È¤òÄÌÃΤ·¤Þ¤¹¡£¼ÂºÝ¤Î ÉÁ²è¥¨¥ê¥¢¤ÎÂ礭¤µ¤Ï¡¢¥°¥é¥Õ¤¬¼¡¤ËÉÁ²è¤µ¤ì¤ë¤È¤­¤Ë¼«Æ°Åª¤Ë¼èÆÀ¤µ¤ì¤Þ¤¹¡£ [procedure] glgd-graph-connect graph drawing-area drawing-area¤Ï¥ª¥Ö¥¸¥§¥¯¥È¤Ç¤¹¡£ ¤³¤Î´Ø¿ô¤Ï¡¢¥°¥é¥Õ¤òdrawing area¤ËÀܳ¤·¤Þ¤¹¡£graph¤Ïdrawing-area ¤Î¼õ¤±¤ë¥¤¥Ù¥ó¥È¤òƱ»þ¤Ë¼õ¤±¤Þ¤¹¡£¤Þ¤¿¡¢drawing-area¤ÎÃæ¤ËÉÁ²è¤ò ¹Ô¤¤¤Þ¤¹¡£ [procedure] glgd-graph-translate graph x y ¥°¥é¥Õ¤ÎÆâÍƤò[x, y]¤À¤±°ÜÆ°¤·¤Þ¤¹¡£x¡¢y¤Ï¼Â¿ô¤Ç¤¹¡£ [procedure] glgd-graph-center graph ¥°¥é¥Õ¤ÎÆâÍƤ¬É½¼¨Îΰè¤ÎÃæ¿´¤ËÍè¤ë¤è¤¦¤Ë°ÜÆ°¤·¤Þ¤¹¡£ [procedure] glgd-graph-auto-organize graph x y ¥Î¡¼¥É¤ä¥ê¥ó¥¯¤òºÆÀ°Îó¤·¤Þ¤¹¡£x¤Èy¤Ï¼Â¿ôÃͤǡ¢¥°¥é¥Õ¤Îº¸¾å¤Î ³Ñ¤ò»ØÄꤷ¤Þ¤¹¡£ [procedure] glgd-graph-node-by-id graph id ¥°¥é¥ÕÃæ¤Ç¡¢¥Î¡¼¥Éid¤È¤·¤Æid¤ò¤ò»ý¤Ä¥Î¡¼¥É¤òÊÖ¤·¤Þ¤¹¡£ glgd-node-id-set»²¾È¡£ [procedure] glgd-graph-node-select-count graph ¸½ºßÁªÂò¤µ¤ì¤Æ¤¤¤ë¥Î¡¼¥É¤Î¿ô¤òÊÖ¤·¤Þ¤¹¡£ [procedure] glgd-graph-node-count graph ¥°¥é¥ÕÃæ¤Î¥Î¡¼¥É¤ÎÁí¿ô¤òÊÖ¤·¤Þ¤¹¡£ [procedure] glgd-graph-node-add graph node ¥Î¡¼¥É¤ò¥°¥é¥Õ¤ËÄɲä·¤Þ¤¹¡£ [procedure] glgd-graph-node-list-flag graph flag-mask flag-op ¥°¥é¥ÕÃæ¤ÎÁ´¤Æ¤Î¤Î¥Î¡¼¥É¤Î¥Õ¥é¥°¤òÁàºî¤·¤Þ¤¹¡£ [procedure] glgd-graph-link-list-add graph link-list ¥ê¥ó¥¯¥ê¥¹¥È¤ò¥°¥é¥Õ¤ËÄɲä·¤Þ¤¹¡£ [procedure] glgd-graph-link-add graph link-list link ¥ê¥ó¥¯¤ò¡¢¥ê¥ó¥¯¥ê¥¹¥È¤È¥°¥é¥Õ¤ËÄɲä·¤Þ¤¹¡£ [procedure] glgd-graph-link-index graph link ¥°¥é¥ÕÃæ¤Ç¤Î¥ê¥ó¥¯¤Î¥¤¥ó¥Ç¥Ã¥¯¥¹ÈÖ¹æ¤òÊÖ¤·¤Þ¤¹¡£ ¥ê¥ó¥¯link¤¬¥°¥é¥ÕÃæ¤Ë¤Ê¤¤¾ì¹ç¤Ï-1¤¬ÊÖ¤µ¤ì¤Þ¤¹¡£ [procedure] glgd-graph-link-by-index graph index ¥¤¥ó¥Ç¥Ã¥¯¥¹ÈÖ¹æindex¤Ç»ØÄꤵ¤ì¤ë¥°¥é¥ÕÃæ¤Î¥ê¥ó¥¯¤òÊÖ¤·¤Þ¤¹¡£ [procedure] glgd-graph-callback-set graph type proc ¥°¥é¥Õ¤Ë¥³¡¼¥ë¥Ð¥Ã¥¯´Ø¿ô¤òÅÐÏ¿¤·¤Þ¤¹¡£type°ú¿ô¤Ï¡¢Äê¿ôGLGDGRAPH_FN_* ¤ÎÃͤΤ¤¤º¤ì¤«¤ò»ØÄꤷ¤Þ¤¹¡£¥³¡¼¥ë¥Ð¥Ã¥¯´Ø¿ô¤Ï4¤Ä¤Î°ú¿ô¤ò¼è¤ê¤Þ¤¹¡§ ¥ª¥Ö¥¸¥§¥¯¥È¡¢¥Õ¥©¡¼¥«¥¹¤Î¤¢¤ë¥ª¥Ö¥¸¥§¥¯¥È¡¢ ¥Õ¥©¡¼¥«¥¹¤Î¤¢¤ë¥ª¥Ö¥¸¥§¥¯¥È¡¢¤½¤·¤Æ¥ª¥Ö¥¸¥§¥¯¥È ¤Ç¤¹¡£ [procedure] glgd-graph-flags-set graph flag-mask flag-op ¥°¥é¥Õ¤Î¥Õ¥é¥°¤òÁàºî¤·¤Þ¤¹¡£ [procedure] glgd-graph-dim-set graph w h ¥°¥é¥Õ¤Î²èÌ̤ÎÂ礭¤µ¤òÀßÄꤷ¤Þ¤¹¡£ [procedure] glgd-graph-margin-set graph margin [procedure] glgd-graph-margin-get graph ¥°¥é¥Õ¤Î¥Þ¡¼¥¸¥ó¤òset/get¤·¤Þ¤¹¡£ [procedure] glgd-graph-line-color-set graph r g b a ¥°¥é¥ÕÆâ¤ÇÀþ¤òÉÁ²è¤¹¤ëºÝ¤Î¿§¤ò»ØÄꤷ¤Þ¤¹¡£ [procedure] glgd-graph-attribute-clear graph [procedure] glgd-graph-attribute-set graph attr-index [procedure] glgd-graph-attribute-toggle graph attr-index [procedure] glgd-graph-attribute-reset graph attr-index [procedure] glgd-graph-attribute-is-set graph attr-index ¥°¥é¥Õ¤Î°À­¤òÁàºî¤·¤Þ¤¹¡£ [procedure] glgd-verbosity verbosity ¥°¥é¥Õ¤Î¥Ç¥Ð¥Ã¥°¥á¥Ã¥»¡¼¥¸¥ì¥Ù¥ë¤ò»ØÄꤷ¤Þ¤¹¡£verbosity¤¬ 0¤è¤êÂ礭¤¤¤È¡¢¥Ç¥Ð¥Ã¥°¥á¥Ã¥»¡¼¥¸¤¬½ÐÎϤµ¤ì¤Þ¤¹¡£ gauche-gtk-0.6+git20160927/glgd/gauche-glgd.c000066400000000000000000000064131300401456300202400ustar00rootroot00000000000000/* * gauche-glgd.c - Gauche+openGLGraphDisplay extension * * Copyright(C) 2004 by Shawn Taras (staras@cementedminds.com) * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in all * distributions. * This software is provided as is, without express or implied * warranty. In no circumstances the author(s) shall be liable * for any damages arising out of the use of this software. * * $Id: gauche-glgd.c,v 1.9 2007/01/13 01:36:30 maruska Exp $ */ #include "gauche-glgd.h" #ifdef HAVE_GTKGL extern void Scm_Init_glgdlib(ScmModule *); /*============================================================= * Scm_GLGDNode */ SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GLGDNodeClass, NULL); glgdNode *Scm_GLGDNodeUnbox(Scm_GLGDNode *Scm_node) { return Scm_node->node; } Scm_GLGDNode *Scm_GLGDNodeBox(glgdNode *node) { Scm_GLGDNode *Scm_node; Scm_node = SCM_NEW(Scm_GLGDNode); SCM_SET_CLASS(Scm_node, SCM_CLASS_GLGD_NODE); Scm_node->node = (glgdNode *)node; return Scm_node; } /*============================================================= * Scm_GLGDLink */ SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GLGDLinkClass, NULL); glgdLink *Scm_GLGDLinkUnbox(Scm_GLGDLink *Scm_link) { return Scm_link->link; } Scm_GLGDLink *Scm_GLGDLinkBox(glgdLink *link) { Scm_GLGDLink *Scm_link; Scm_link = SCM_NEW(Scm_GLGDLink); SCM_SET_CLASS(Scm_link, SCM_CLASS_GLGD_LINK); Scm_link->link = (glgdLink *)link; return Scm_link; } /*========================================================== * Scm_GLGDLinkList */ SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GLGDLinkListClass, NULL); glgdLinkList *Scm_GLGDLinkListUnbox(Scm_GLGDLinkList *Scm_list) { return Scm_list->list; } Scm_GLGDLinkList *Scm_GLGDLinkListBox(glgdLinkList *list) { Scm_GLGDLinkList *Scm_list; Scm_list = SCM_NEW(Scm_GLGDLinkList); SCM_SET_CLASS(Scm_list, SCM_CLASS_GLGD_LINKLIST); Scm_list->list = (glgdLinkList *)list; return Scm_list; } /*========================================================== * Scm_GLGDGraph */ SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GLGDGraphClass, NULL); glgdGraph *Scm_GLGDGraphUnbox(Scm_GLGDGraph *Scm_graph) { return Scm_graph->graph; } Scm_GLGDGraph *Scm_GLGDGraphBox(glgdGraph *graph) { Scm_GLGDGraph *Scm_graph; Scm_graph = SCM_NEW(Scm_GLGDGraph); SCM_SET_CLASS(Scm_graph, SCM_CLASS_GLGD_GRAPH); Scm_graph->graph = (glgdGraph *)graph; return Scm_graph; } /*========================================================== * Initialization */ void Scm_Init_gauche_glgd(void) { ScmModule *mod; SCM_INIT_EXTENSION(gauche_glgd); mod = SCM_MODULE(SCM_FIND_MODULE("gtk.glgd", TRUE)); Scm_InitBuiltinClass(SCM_CLASS_GLGD_NODE, "", NULL, sizeof(Scm_GLGDNode), mod); Scm_InitBuiltinClass(SCM_CLASS_GLGD_LINK, "", NULL, sizeof(Scm_GLGDLink), mod); Scm_InitBuiltinClass(SCM_CLASS_GLGD_GRAPH, "", NULL, sizeof(Scm_GLGDGraph), mod); Scm_Init_glgdlib(mod); } #endif /*HAVE_GTKGL*/ gauche-gtk-0.6+git20160927/glgd/gauche-glgd.h000066400000000000000000000073541300401456300202520ustar00rootroot00000000000000/* * gauche-glgd.h - Gauche+openGLGraphDisplay extension * * Copyright(C) 2004 by Shawn Taras (staras@cementedminds.com) * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in all * distributions. * This software is provided as is, without express or implied * warranty. In no circumstances the author(s) shall be liable * for any damages arising out of the use of this software. * * $Id: gauche-glgd.h,v 1.9 2007/01/13 01:36:30 maruska Exp $ */ #ifndef GAUCHE_GLGD_H #define GAUCHE_GLGD_H #include #include #include #include "../src/gauche-gtk.h" #include "../src/gtk-config.h" #include "glgd.h" #ifdef HAVE_GTKGL SCM_DECL_BEGIN /*==================================================================== * glgd classes */ /*------------------------- * Scm_GLGDNode */ typedef struct _Scm_GLGDNode { SCM_HEADER; glgdNode *node; } Scm_GLGDNode; SCM_CLASS_DECL(Scm_GLGDNodeClass); #define SCM_CLASS_GLGD_NODE (&Scm_GLGDNodeClass) #define SCM_GLGD_NODE_P(obj) (Scm_TypeP(obj, SCM_CLASS_GLGD_NODE)) #define SCM_GLGD_NODE(obj) (Scm_GLGDNodeUnbox((Scm_GLGDNode *)obj)) #define SCM_MAKE_GLGD_NODE(obj) ((ScmObj)Scm_GLGDNodeBox(obj)) #define SCM_GLGD_NODE_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GLGD_NODE_P(obj)) /*------------------------- * Scm_GLGDLink */ typedef struct _Scm_GLGDLink { SCM_HEADER; glgdLink *link; } Scm_GLGDLink; SCM_CLASS_DECL(Scm_GLGDLinkClass); #define SCM_CLASS_GLGD_LINK (&Scm_GLGDLinkClass) #define SCM_GLGD_LINK_P(obj) (Scm_TypeP(obj, SCM_CLASS_GLGD_LINK)) #define SCM_GLGD_LINK(obj) (Scm_GLGDLinkUnbox((Scm_GLGDLink *)obj)) #define SCM_MAKE_GLGD_LINK(obj) ((ScmObj)Scm_GLGDLinkBox(obj)) #define SCM_GLGD_LINK_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GLGD_LINK_P(obj)) /*------------------------- * Scm_GLGDLinkList */ typedef struct _Scm_GLGDLinkList { SCM_HEADER; glgdLinkList *list; } Scm_GLGDLinkList; SCM_CLASS_DECL(Scm_GLGDLinkListClass); #define SCM_CLASS_GLGD_LINKLIST (&Scm_GLGDLinkListClass) #define SCM_GLGD_LINKLIST_P(obj) (Scm_TypeP(obj, SCM_CLASS_GLGD_LINKLIST)) #define SCM_GLGD_LINKLIST(obj) (Scm_GLGDLinkListUnbox((Scm_GLGDLinkList *)obj)) #define SCM_MAKE_GLGD_LINKLIST(obj) ((ScmObj)Scm_GLGDLinkListBox(obj)) #define SCM_GLGD_LINKLIST_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GLGD_LINKLIST_P(obj)) /*------------------------- * Scm_GLGDGraph */ typedef struct _Scm_GLGDGraph { SCM_HEADER; glgdGraph *graph; } Scm_GLGDGraph; SCM_CLASS_DECL(Scm_GLGDGraphClass); #define SCM_CLASS_GLGD_GRAPH (&Scm_GLGDGraphClass) #define SCM_GLGD_GRAPH_P(obj) (Scm_TypeP(obj, SCM_CLASS_GLGD_GRAPH)) #define SCM_GLGD_GRAPH(obj) (Scm_GLGDGraphUnbox((Scm_GLGDGraph *)obj)) #define SCM_MAKE_GLGD_GRAPH(obj) ((ScmObj)Scm_GLGDGraphBox(obj)) #define SCM_GLGD_GRAPH_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GLGD_GRAPH_P(obj)) /*------------------------- * Function Prototypes */ glgdNode *Scm_GLGDNodeUnbox(Scm_GLGDNode *Scm_node); Scm_GLGDNode *Scm_GLGDNodeBox(glgdNode *node); glgdLink *Scm_GLGDLinkUnbox(Scm_GLGDLink *Scm_link); Scm_GLGDLink *Scm_GLGDLinkBox(glgdLink *link); glgdLinkList *Scm_GLGDLinkListUnbox(Scm_GLGDLinkList *Scm_list); Scm_GLGDLinkList *Scm_GLGDLinkListBox(glgdLinkList *list); glgdGraph *Scm_GLGDGraphUnbox(Scm_GLGDGraph *Scm_graph); Scm_GLGDGraph *Scm_GLGDGraphBox(glgdGraph *graph); SCM_DECL_END #endif /*HAVE_GTKGL*/ #endif /*GAUCHE_GLGD_H*/ gauche-gtk-0.6+git20160927/glgd/glgd.h000066400000000000000000000014021300401456300170040ustar00rootroot00000000000000/* * glgd.h * * OpenGL Graph Display library header file * * Written by: Shawn Taras */ #ifndef __GLGD_H__ #define __GLGD_H__ /* Trace output functions (implemented in glgdGraph.c) */ int glgdVerbosity(int verbosity); int glgdTrace(int level, const char *fmt, ...); #include #include #include #include #ifdef HAVE_GLGD_PANGO #include #endif /* HAVE_GLGD_PANGO */ #include "glgdDefines.h" #include "glgdTypes.h" #include "glgdBitfield.h" #include "glgdStroke.h" #include "glgdTexture.h" #include "glgdQuat.h" #include "glgdMatrix.h" #include "glgdCam.h" #include "glgdDraw.h" #include "glgdNode.h" #include "glgdLink.h" #include "glgdGraph.h" #endif /* __GLGD_H__ */ gauche-gtk-0.6+git20160927/glgd/glgd.types000066400000000000000000000032141300401456300177240ustar00rootroot00000000000000;;; ;;; glgd.types - common type defs for OpenGL Graph Display library ;;; ;;; Copyright(C) 2004 by Shawn Taras (staras@cementedminds.com) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: glgd.types,v 1.6 2007/01/13 01:36:30 maruska Exp $ ;;; (include "../src/gtk-lib.types") (define-type "glgdGraph*" #f "SCM_GLGD_GRAPH_P" "SCM_GLGD_GRAPH" "SCM_MAKE_GLGD_GRAPH") (define-type -or-null "glgdGraph*" #f "SCM_GLGD_GRAPH_OR_NULL_P" "SCM_GLGD_GRAPH" "SCM_MAKE_GLGD_GRAPH") (define-type "glgdNode*" #f "SCM_GLGD_NODE_P" "SCM_GLGD_NODE" "SCM_MAKE_GLGD_NODE") (define-type -or-null "glgdNode*" #f "SCM_GLGD_NODE_OR_NULL_P" "SCM_GLGD_NODE" "SCM_MAKE_GLGD_NODE") (define-type "glgdLink*" #f "SCM_GLGD_LINK_P" "SCM_GLGD_LINK" "SCM_MAKE_GLGD_LINK") (define-type -or-null "glgdLink*" #f "SCM_GLGD_LINK_OR_NULL_P" "SCM_GLGD_LINK" "SCM_MAKE_GLGD_LINK") (define-type "glgdLinkList*" #f "SCM_GLGD_LINKLIST_P" "SCM_GLGD_LINKLIST" "SCM_MAKE_GLGD_LINKLIST") (define-type -or-null "glgdLinkList*" #f "SCM_GLGD_LINKLIST_OR_NULL_P" "SCM_GLGD_LINKLIST" "SCM_MAKE_GLGD_LINKLIST") ;; Local variables: ;; mode: scheme ;; end: gauche-gtk-0.6+git20160927/glgd/glgdBitfield.c000066400000000000000000000057721300401456300204600ustar00rootroot00000000000000/* * gldgBitfield.c * * OpenGL Graph Display bitfield utility module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" /* * External public functions */ GLboolean glgdBitfieldInit(glgdBitfield *bits) { if (bits != NULL) { return glgdBitfieldClear(bits); } return GL_FALSE; } GLboolean glgdBitfieldFini(glgdBitfield *bits) { return glgdBitfieldInit(bits); } GLboolean glgdBitfieldClear(glgdBitfield *bits) { int i; if (bits != NULL) { for (i=0; ibits[i] = 0x00; } return GL_TRUE; } return GL_FALSE; } GLboolean glgdBitfieldSet(glgdBitfield *bits, int bitNdx) { int byteNdx; GLubyte mask; if (bits != NULL && bitNdx >= 0 && bitNdx < GLGDBITFIELD_BIT_COUNT) { byteNdx = bitNdx / GLGDBITFIELD_BITS_PER_BYTE; mask = 0x1 << (bitNdx % GLGDBITFIELD_BITS_PER_BYTE); if ((bits->bits[byteNdx] & mask) == 0x00) { bits->bits[byteNdx] |= mask; /* Only return GL_TRUE if it was actually set! */ return GL_TRUE; } } return GL_FALSE; } GLboolean glgdBitfieldToggle(glgdBitfield *bits, int bitNdx) { int byteNdx; GLubyte mask; if (bits != NULL && bitNdx >= 0 && bitNdx < GLGDBITFIELD_BIT_COUNT) { byteNdx = bitNdx / GLGDBITFIELD_BITS_PER_BYTE; mask = 0x1 << (bitNdx % GLGDBITFIELD_BITS_PER_BYTE); bits->bits[byteNdx] ^= mask; return GL_TRUE; } return GL_FALSE; } GLboolean glgdBitfieldReset(glgdBitfield *bits, int bitNdx) { int byteNdx; GLubyte mask; if (bits != NULL && bitNdx >= 0 && bitNdx < GLGDBITFIELD_BIT_COUNT) { byteNdx = bitNdx / GLGDBITFIELD_BITS_PER_BYTE; mask = 0x1 << (bitNdx % GLGDBITFIELD_BITS_PER_BYTE); if (bits->bits[byteNdx] & mask) { bits->bits[byteNdx] &= ~mask; /* Only return GL_TRUE if it was actually reset! */ return GL_TRUE; } } return GL_FALSE; } GLboolean glgdBitfieldIsSet(glgdBitfield *bits, int bitNdx) { int byteNdx; GLubyte mask; if (bits != NULL && bitNdx >= 0 && bitNdx < GLGDBITFIELD_BIT_COUNT) { byteNdx = bitNdx / GLGDBITFIELD_BITS_PER_BYTE; mask = 0x1 << (bitNdx % GLGDBITFIELD_BITS_PER_BYTE); if (bits->bits[byteNdx] & mask) { return GL_TRUE; } } return GL_FALSE; } GLboolean glgdBitfieldCompare(glgdBitfield *a, glgdBitfield *b) { int i; if (a && b) { for (i=0; ibits[i] & b->bits[i]) { /* Something matches! */ return GL_TRUE; } } } return GL_FALSE; } gauche-gtk-0.6+git20160927/glgd/glgdBitfield.h000066400000000000000000000020351300401456300204520ustar00rootroot00000000000000/* * gldgBitfield.h * * OpenGL Graph Display bitfield utility module header file * * Written by: Shawn Taras */ #ifndef __GLGDBITFIELD_H__ #define __GLGDBITFIELD_H__ SCM_DECL_BEGIN /* * Defines */ #define GLGDBITFIELD_BIT_COUNT (256) #define GLGDBITFIELD_BITS_PER_BYTE (8) #define GLGDBITFIELD_BYTE_COUNT (GLGDBITFIELD_BIT_COUNT / GLGDBITFIELD_BITS_PER_BYTE) /* * Type Definitions */ typedef struct _glgdBitfield { GLubyte bits[GLGDBITFIELD_BYTE_COUNT]; } glgdBitfield; /* * Module API */ GLboolean glgdBitfieldInit(glgdBitfield *bits); GLboolean glgdBitfieldFini(glgdBitfield *bits); GLboolean glgdBitfieldClear(glgdBitfield *bits); GLboolean glgdBitfieldSet(glgdBitfield *bits, int bitNdx); GLboolean glgdBitfieldToggle(glgdBitfield *bits, int bitNdx); GLboolean glgdBitfieldReset(glgdBitfield *bits, int bitNdx); GLboolean glgdBitfieldIsSet(glgdBitfield *bits, int bitNdx); GLboolean glgdBitfieldCompare(glgdBitfield *a, glgdBitfield *b); SCM_DECL_END #endif /* __GLGDBITFIELD_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdCam.c000066400000000000000000000177511300401456300174360ustar00rootroot00000000000000/* * gldgCam.c * * OpenGL Graph Display camera control module implementation * * Written by: Shawn Taras */ #include #include #include #include #include #include #include "glgd.h" /* * Defines */ #define _PI (M_PI) #define _DEG2RAD(x) ((x) * _PI / 180.0) /* * External public functions */ GLboolean glgdCamInit(glgdCam *cam) { if (cam != NULL) { cam->flags = GLGDCAM_FLAG_INITIALIZED; glgdMatrixIdentity(cam->projMtx); glgdQuatIdentity(cam->camRot); cam->camPos[0] = 0.0; cam->camPos[1] = 0.0; cam->camPos[2] = 0.0; cam->mouseLast[0] = -1.0; cam->mouseLast[1] = -1.0; cam->tanFOV[0] = 0.414; /* 45 degree FOV */ cam->tanFOV[1] = 0.414; cam->winDim[0] = 0.0; cam->winDim[1] = 0.0; return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamBegin(glgdCam *cam) { glgdMatrix camRotMtx; if (cam) { /* Load the projection matrix */ glMatrixMode(GL_PROJECTION); glLoadMatrixd(cam->projMtx); /* Compute and load the modelview matrix */ glMatrixMode(GL_MODELVIEW); glPushMatrix(); glLoadIdentity(); glTranslated(cam->camPos[0], cam->camPos[1], cam->camPos[2]); glgdMatrixSetByQuat(camRotMtx, cam->camRot); glMultMatrixd(camRotMtx); return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamBeginPick(glgdCam *cam, GLdouble mx, GLdouble my) { GLint viewport[4]; glgdMatrix camRotMtx; if (cam) { glGetIntegerv(GL_VIEWPORT, viewport); /* Load the projection matrix */ glMatrixMode(GL_PROJECTION); glLoadIdentity(); gluPickMatrix(mx, viewport[3] - my, 8.0, 8.0, viewport); glMultMatrixd(cam->projMtx); /* Compute and load the modelview matrix */ glMatrixMode(GL_MODELVIEW); glPushMatrix(); glLoadIdentity(); glTranslated(cam->camPos[0], cam->camPos[1], cam->camPos[2]); glgdMatrixSetByQuat(camRotMtx, cam->camRot); glMultMatrixd(camRotMtx); return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamUpdate(glgdCam *cam, glgdCamMode mode, GLdouble mx, GLdouble my, GLdouble frameTime) { glgdQuat qa, qb, qc; GLdouble scale; GLdouble ratio[2]; GLdouble dx, dy; GLboolean something; if (frameTime <= 0.016667) { frameTime = 0.016667; } if (cam != NULL) { something = GL_FALSE; if (mode == GLGDCAM_MODE_NONE) { cam->mouseLast[0] = -1.0; cam->mouseLast[1] = -1.0; } else { if (cam->mouseLast[0] >= 0.0) { dx = mx - cam->mouseLast[0]; dy = my - cam->mouseLast[1]; if (mode == GLGDCAM_MODE_ORBIT) { scale = 10.0 * frameTime; glgdQuatSetByXRotation(qa, _DEG2RAD(dy * scale)); glgdQuatSetByYRotation(qb, _DEG2RAD(dx * scale)); glgdQuatMult(qc, qb, cam->camRot); glgdQuatMult(cam->camRot, qc, qa); } else if (mode == GLGDCAM_MODE_ZOOM) { scale = 10.0 * frameTime; cam->camPos[2] += dx * scale; } else if (mode == GLGDCAM_MODE_PAN) { ratio[0] = cam->camPos[2]*cam->tanFOV[0]/cam->winDim[0]; ratio[1] = cam->camPos[2]*cam->tanFOV[1]/cam->winDim[1]; cam->camPos[0] -= dx * ratio[0]; cam->camPos[1] += dy * ratio[1]; } } cam->mouseLast[0] = mx; cam->mouseLast[1] = my; something = GL_TRUE; } return something; } return GL_FALSE; } GLboolean glgdCamEnd(glgdCam *cam) { if (cam) { glMatrixMode(GL_MODELVIEW); glPopMatrix(); return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamPosSet(glgdCam *cam, GLdouble x, GLdouble y, GLdouble z) { if (cam) { cam->camPos[0] = x; cam->camPos[1] = y; cam->camPos[2] = z; return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamWinDimSet(glgdCam *cam, GLdouble w, GLdouble h) { if (cam) { cam->winDim[0] = w; cam->winDim[1] = h; return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamRotSet(glgdCam *cam, glgdQuat qrot) { if (cam) { return glgdQuatSet(cam->camRot, qrot); } return GL_FALSE; } GLboolean glgdCamMouseSet(glgdCam *cam, GLdouble mx, GLdouble my) { if (cam) { cam->mouseLast[0] = mx; cam->mouseLast[1] = my; } return GL_FALSE; } GLboolean glgdCamFrameWidth(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top) { GLdouble z; GLdouble w, h; w = right - left; h = top - bottom; if (cam && w > 0.0 && h > 0.0) { cam->camPos[0] = -GLGD_HALF(left + right); cam->camPos[1] = -GLGD_HALF(bottom + top); cam->camPos[2] = -(w * 0.5) / tan(cam->tanFOV[0]); return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamFrameHeight (glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top) { GLdouble z; GLdouble w, h; w = right - left; h = top - bottom; if (cam && w > 0.0 && h > 0.0) { cam->camPos[0] = -GLGD_HALF(left + right); cam->camPos[1] = -GLGD_HALF(bottom + top); cam->camPos[2] = -(h * 0.5) / cam->tanFOV[1]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamFrame(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top) { GLdouble w, h; w = right - left; h = top - bottom; if (cam && w > 0.0 && h > 0.0) { if (w > h) { glgdCamFrameWidth(cam, left, right, bottom, top); } else { glgdCamFrameHeight(cam, left, right, bottom, top); } glgdTrace(2, "(%g,%g,%g,%g) -> (%g,%g,%g)\n", left, right, bottom, top, cam->camPos[0], cam->camPos[1], cam->camPos[2]); return GL_TRUE; } return GL_FALSE; } GLboolean glgdCamPerspective(glgdCam *cam, GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar) { GLdouble fovyBy2; glgdMatrixPerspective(cam->projMtx, fovy, aspect, zNear, zFar); fovyBy2 = fovy * 0.5; cam->tanFOV[0] = tan(fovyBy2 / aspect); cam->tanFOV[1] = tan(fovyBy2); return GL_FALSE; } GLboolean glgdCamFrustum(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar) { GLdouble aspect; GLdouble fovyBy2; glgdMatrixFrustum(cam->projMtx, left, right, bottom, top, zNear, zFar); aspect = (top - bottom) / (right - left); fovyBy2 = atan2((top - bottom) * 0.5, zNear); cam->tanFOV[0] = tan(fovyBy2 / aspect); cam->tanFOV[1] = tan(fovyBy2); return GL_FALSE; } GLboolean glgdCamOrtho(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar) { glgdMatrixOrtho(cam->projMtx, left, right, bottom, top, zNear, zFar); return GL_FALSE; } gauche-gtk-0.6+git20160927/glgd/glgdCam.h000066400000000000000000000050521300401456300174320ustar00rootroot00000000000000/* * glgdCam.h * * OpenGL Graph Display camera control module header file * * Written by: Shawn Taras */ #ifndef __GLGDCAM_H__ #define __GLGDCAM_H__ SCM_DECL_BEGIN /* * Enumerations */ typedef enum { GLGDCAM_MODE_NONE = 0, GLGDCAM_MODE_ORBIT, GLGDCAM_MODE_ZOOM, GLGDCAM_MODE_PAN, GLGDCAM_MODE_COUNT } glgdCamMode; /* * Defines */ #define GLGDCAM_FLAG_INITIALIZED (0x0001) /* * Type Definitions */ typedef struct _glgdCam { GLbitfield flags; glgdMatrix projMtx; glgdQuat camRot; GLdouble camPos[3]; GLdouble mouseLast[2]; GLdouble tanFOV[2]; GLdouble winDim[2]; } glgdCam; typedef GLboolean (*glgdCamCtrlFn)(glgdCam *cam); /* * Module API */ GLboolean glgdCamInit(glgdCam *cam); GLboolean glgdCamBegin(glgdCam *cam); GLboolean glgdCamBeginPick(glgdCam *cam, GLdouble mx, GLdouble my); GLboolean glgdCamUpdate(glgdCam *cam, glgdCamMode mode, GLdouble mx, GLdouble my, GLdouble frameTime); GLboolean glgdCamEnd(glgdCam *cam); GLboolean glgdCamWinDimSet(glgdCam *cam, GLdouble w, GLdouble h); GLboolean glgdCamPosSet(glgdCam *cam, GLdouble x, GLdouble y, GLdouble z); GLboolean glgdCamRotSet(glgdCam *cam, glgdQuat qrot); GLboolean glgdCamMouseSet(glgdCam *cam, GLdouble mx, GLdouble my); GLboolean glgdCamFrameWidth(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top); GLboolean glgdCamFrameHeight(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top); GLboolean glgdCamFrame(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top); GLboolean glgdCamPerspective(glgdCam *cam, GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar); GLboolean glgdCamFrustum(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar); GLboolean glgdCamOrtho(glgdCam *cam, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar); /* * Camera control functions */ GLboolean glgdCamCtrlMaya(glgdCam *cam); GLboolean glgdCamCtrl3DSMax(glgdCam *cam); SCM_DECL_END #endif /* __GLGDCAM_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdDefines.h000066400000000000000000000015261300401456300203110ustar00rootroot00000000000000/* * gldgDefines.h * * OpenGL Graph Display module common defines header file * * Written by: Shawn Taras */ #ifndef __GLGDDEFINES_H__ #define __GLGDDEFINES_H__ SCM_DECL_BEGIN /* * Enumerations */ typedef enum { GLGD_FLAGOP_CLEAR = 0, GLGD_FLAGOP_SET, GLGD_FLAGOP_TOGGLE, GLGD_FLAGOP_COUNT } glgdFlagOp; /* * Defines */ #define GLGD_MALLOC SCM_MALLOC #define GLGD_FREE sizeof #define GLGD_ATTR_FORCEVISIBLE (0xFF) #define GLGD_MAX(a, b) ((a) > (b) ? (a) : (b)) #define GLGD_MIN(a, b) ((a) < (b) ? (a) : (b)) #define GLGD_EIGHTH(x) ((x) * 0.125) #define GLGD_QUARTER(x) ((x) * 0.250) #define GLGD_HALF(x) ((x) * 0.500) #define GLGD_THREEQUARTER(x) ((x) * 0.750) SCM_DECL_END #endif /* __GLGDDEFINES_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdDraw.c000066400000000000000000000410351300401456300176230ustar00rootroot00000000000000/* * gldgDraw.c * * OpenGL Graph Display primitive drawing module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" /* * Defines */ #define GLGDDRAW_BW1 (4.0f) #define GLGDDRAW_BW2 (2.0f) /* * Global variables */ glgdColor g_colorBlack = {0.0, 0.0, 0.0, 1.0}; glgdColor g_colorWhite = {1.0, 1.0, 1.0, 1.0}; glgdColor g_colorRed = {1.0, 0.0, 0.0, 1.0}; glgdColor g_colorGreen = {0.0, 1.0, 0.0, 1.0}; glgdColor g_colorBlue = {0.0, 0.0, 1.0, 1.0}; glgdColor g_colorYellow = {1.0, 1.0, 0.0, 1.0}; glgdColor g_colorCyan = {0.0, 1.0, 1.0, 1.0}; glgdColor g_colorMagenta = {1.0, 0.0, 1.0, 1.0}; /* * Static local (to this module) variables */ static glgdColor s_colorBlack = {0.0, 0.0, 0.0, 1.0}; static GLdouble s_zValue = 0.0f; static GLdouble s_lineWidth = 1.0f; static GLint s_blendFunc[2] = {GL_ONE, GL_ZERO}; /* * Static local (to this module) functions */ static void glgdPushAttributes(void) { glPushAttrib(GL_ENABLE_BIT | GL_HINT_BIT | GL_LINE_BIT); glGetIntegerv(GL_BLEND_SRC, &s_blendFunc[0]); glGetIntegerv(GL_BLEND_DST, &s_blendFunc[1]); /* Common attributes for primitive drawing */ glDisable(GL_TEXTURE_2D); glDisable(GL_LIGHTING); glDisable(GL_DEPTH_TEST); glLineWidth((GLfloat)s_lineWidth); } static void glgdPopAttributes(void) { glPopAttrib(); glBlendFunc(s_blendFunc[0], s_blendFunc[1]); } static void glgdDrawColorSet(glgdColor col, GLboolean isLine) { if (isLine) { glEnable(GL_LINE_SMOOTH); glHint(GL_LINE_SMOOTH_HINT, GL_NICEST); glEnable(GL_BLEND); glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); glColor4d(col[0], col[1], col[2], col[3]); } else if (col[3] < 1.0) { glEnable(GL_BLEND); glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); glColor4d(col[0], col[1], col[2], col[3]); } else { glDisable(GL_BLEND); glColor3d(col[0], col[1], col[2]); } } static GLdouble glgdDrawLERP ( GLdouble val, GLdouble smin, GLdouble smax, GLdouble gmin, GLdouble gmax ) { if (smin == smax) { return gmax; } else { return gmin + (gmax - gmin) * (val - smin) / (smax - smin); } } /* * External public functions */ void glgdDrawZValueSet(GLdouble zValue) { s_zValue = zValue; } void glgdDrawZValueGet(GLdouble *zValue) { if (zValue) { *zValue = s_zValue; } } void glgdDrawLineWidthSet(GLdouble lineWidth) { s_lineWidth = lineWidth; } void glgdDrawLineWidthGet(GLdouble *lineWidth) { if (lineWidth) { *lineWidth = s_lineWidth; } } void glgdDrawLine(glgdVec2 xy, glgdVec2 wh, glgdColor col) { GLdouble x1, y1; GLdouble x2, y2; x1 = xy[0]; y1 = xy[1]; x2 = x1 + wh[0] - 1.0f; y2 = y1 + wh[1] - 1.0f; glgdDrawColorSet(col, GL_TRUE); glBegin(GL_LINE_STRIP); glVertex3d(x1, y1, s_zValue); glVertex3d(x2, y2, s_zValue); glEnd(); } void glgdDrawRect(glgdVec2 xy, glgdVec2 wh, glgdColor col) { GLdouble x1, y1; GLdouble x2, y2; x1 = xy[0]; y1 = xy[1]; x2 = x1 + wh[0]; y2 = y1 + wh[1]; glgdDrawColorSet(col, GL_FALSE); glBegin(GL_TRIANGLE_STRIP); glVertex3d(x1, y1, s_zValue); glVertex3d(x1, y2, s_zValue); glVertex3d(x2, y1, s_zValue); glVertex3d(x2, y2, s_zValue); glEnd(); } void glgdDrawBoundary(glgdVec2 xy, glgdVec2 wh, glgdColor col) { GLdouble x1, y1; GLdouble x2, y2; x1 = xy[0]; y1 = xy[1]; x2 = x1 + wh[0] - 1.0f; y2 = y1 + wh[1] - 1.0f; glgdDrawColorSet(col, GL_TRUE); glBegin(GL_LINE_LOOP); glVertex3d(x1, y1, s_zValue); glVertex3d(x2, y1, s_zValue); glVertex3d(x2, y2, s_zValue); glVertex3d(x1, y2, s_zValue); glEnd(); } void glgdDrawRectBoundary(glgdVec2 xy, glgdVec2 wh, glgdColor col) { GLdouble x1, y1; GLdouble x2, y2; x1 = xy[0]; y1 = xy[1]; x2 = x1 + wh[0] - 1.0f; y2 = y1 + wh[1]; /* Draw the rectangle */ glgdDrawColorSet(col, GL_FALSE); glBegin(GL_TRIANGLE_STRIP); glVertex3d(x1 + 1.0f, y1, s_zValue); glVertex3d(x1 + 1.0f, y2, s_zValue); glVertex3d(x2, y1, s_zValue); glVertex3d(x2, y2, s_zValue); glEnd(); /* Draw the boundary */ glgdDrawColorSet(s_colorBlack, GL_TRUE); glBegin(GL_LINE_LOOP); glVertex3d(x1, y1, s_zValue); glVertex3d(x2, y1, s_zValue); glVertex3d(x2, y2, s_zValue); glVertex3d(x1, y2, s_zValue); glEnd(); } void glgdDrawQuad ( glgdVec2 a, glgdVec2 b, glgdVec2 c, glgdVec2 d, glgdColor col ) { glgdDrawColorSet(col, GL_FALSE); glBegin(GL_TRIANGLE_STRIP); glVertex3d(a[0], a[1], s_zValue); glVertex3d(b[0], b[1], s_zValue); glVertex3d(d[0], d[1], s_zValue); glVertex3d(c[0], c[1], s_zValue); glEnd(); } void glgdDrawQuadBoundary ( glgdVec2 a, glgdVec2 b, glgdVec2 c, glgdVec2 d, glgdColor col ) { glgdDrawQuad(a, b, c, d, col); /* Draw the boundary */ glgdDrawColorSet(s_colorBlack, GL_TRUE); glBegin(GL_LINE_LOOP); glVertex3d(a[0], a[1], s_zValue); glVertex3d(b[0], b[1], s_zValue); glVertex3d(c[0], c[1], s_zValue); glVertex3d(d[0], d[1], s_zValue); glEnd(); } void glgdDrawBox ( glgdDrawBoxType boxType, glgdVec2 xy, glgdVec2 wh, glgdColor col, GLdouble borderWidth ) { GLdouble borderHeight; glgdVec2 tmpXY; glgdVec2 tmpWH; glgdVec2 qxy[4]; glgdColor tmpCol; if (boxType == GLGDDRAW_BOXTYPE_NONE) { return; } borderHeight = borderWidth; glgdPushAttributes(); switch (boxType) { case GLGDDRAW_BOXTYPE_UP: tmpXY[0] = xy[0] + borderWidth; tmpXY[1] = xy[1] + borderHeight; tmpWH[0] = wh[0] - 2.0f * borderWidth - 1.0f; tmpWH[1] = wh[1] - 2.0f * borderHeight - 1.0f; glgdDrawRect(tmpXY, tmpWH, col); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_DARKEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_DARKEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_DARKEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0]; tmpXY[1] = xy[1]; tmpWH[0] = wh[0] - 1.0f; tmpWH[1] = borderHeight; glgdDrawRect(tmpXY, tmpWH, tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_LIGHTEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_LIGHTEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_LIGHTEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0]; tmpXY[1] = xy[1] + wh[1] - borderHeight - 1.0f; tmpWH[0] = wh[0] - 1.0f; tmpWH[1] = borderHeight; glgdDrawRect(tmpXY, tmpWH, tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_DARKEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_DARKEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_DARKEN); tmpCol[3] = col[3]; qxy[0][0] = xy[0]; qxy[0][1] = xy[1]; qxy[1][0] = xy[0]; qxy[1][1] = xy[1] + wh[1] - 1.0f; qxy[2][0] = xy[0] + borderWidth; qxy[2][1] = xy[1] + wh[1] - borderHeight - 1.0f; qxy[3][0] = xy[0] + borderWidth; qxy[3][1] = xy[1] + borderHeight; glgdDrawQuad(qxy[0], qxy[1], qxy[2], qxy[3], tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_LIGHTEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_LIGHTEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_LIGHTEN); qxy[0][0] = xy[0] + wh[0] - borderWidth - 1.0f; qxy[0][1] = xy[1] + borderHeight; qxy[1][0] = xy[0] + wh[0] - borderWidth - 1.0f; qxy[1][1] = xy[1] + wh[1] - borderHeight - 1.0f; qxy[2][0] = xy[0] + wh[0] - 1.0f; qxy[2][1] = xy[1] + wh[1] - 1.0f; qxy[3][0] = xy[0] + wh[0] - 1.0f; qxy[3][1] = xy[1]; glgdDrawQuad(qxy[0], qxy[1], qxy[2], qxy[3], tmpCol); glgdDrawBoundary(xy, wh, col); break; case GLGDDRAW_BOXTYPE_DOWN: tmpXY[0] = xy[0] + borderWidth + 1.0f; tmpXY[1] = xy[1] + borderHeight + 1.0f; tmpWH[0] = wh[0] - 2.0f * borderWidth - 2.0f; tmpWH[1] = wh[1] - 2.0f * borderHeight - 1.0f; glgdDrawRectBoundary(tmpXY, tmpWH, col); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_DARKEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_DARKEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_DARKEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0]; tmpXY[1] = xy[1]; tmpWH[0] = wh[0]; tmpWH[1] = borderHeight; glgdDrawRect(tmpXY, tmpWH, tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_LIGHTEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_LIGHTEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_LIGHTEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0]; tmpXY[1] = xy[1] + wh[1] - borderHeight; tmpWH[0] = wh[0]; tmpWH[1] = borderHeight; glgdDrawRect(tmpXY, tmpWH, tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_DARKEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_DARKEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_DARKEN); tmpCol[3] = col[3]; qxy[0][0] = xy[0]; qxy[0][1] = xy[1]; qxy[1][0] = xy[0]; qxy[1][1] = xy[1] + wh[1]; qxy[2][0] = xy[0] + borderWidth; qxy[2][1] = xy[1] + wh[1] - borderHeight; qxy[3][0] = xy[0] + borderWidth; qxy[3][1] = xy[1] + borderHeight; glgdDrawQuad(qxy[0], qxy[1], qxy[2], qxy[3], tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_LIGHTEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_LIGHTEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_LIGHTEN); qxy[0][0] = xy[0] + wh[0] - borderWidth; qxy[0][1] = xy[1] + borderHeight; qxy[1][0] = xy[0] + wh[0] - borderWidth; qxy[1][1] = xy[1] + wh[1] - borderHeight; qxy[2][0] = xy[0] + wh[0]; qxy[2][1] = xy[1] + wh[1]; qxy[3][0] = xy[0] + wh[0]; qxy[3][1] = xy[1]; glgdDrawQuad(qxy[0], qxy[1], qxy[2], qxy[3], tmpCol); break; case GLGDDRAW_BOXTYPE_FLAT: glgdDrawRect(xy, wh, col); break; case GLGDDRAW_BOXTYPE_BORDER: glgdDrawRectBoundary(xy, wh, col); break; case GLGDDRAW_BOXTYPE_SHADOW: /* The Shadow */ tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_DARKEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_DARKEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_DARKEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0] + borderWidth; tmpXY[1] = xy[1] + wh[1]; tmpWH[0] = wh[0]; tmpWH[1] = borderHeight; glgdDrawRect(tmpXY, tmpWH, tmpCol); tmpXY[0] = xy[0] + wh[0]; tmpXY[1] = xy[1] + borderHeight; tmpWH[0] = borderWidth; tmpWH[1] = wh[1]; glgdDrawRect(tmpXY, tmpWH, tmpCol); /* The box */ glgdDrawRectBoundary(xy, wh, col); break; case GLGDDRAW_BOXTYPE_FRAME: glgdDrawRect(xy, wh, col); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_DARKEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_DARKEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_DARKEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0]; tmpXY[1] = xy[1]; tmpWH[0] = wh[0] - 2.0f; tmpWH[1] = wh[1] - 2.0f; glgdDrawBoundary(tmpXY, tmpWH, tmpCol); tmpCol[0] = GLGDDRAW_COLORCLAMP(col[0] * GLGDDRAW_LIGHTEN); tmpCol[1] = GLGDDRAW_COLORCLAMP(col[1] * GLGDDRAW_LIGHTEN); tmpCol[2] = GLGDDRAW_COLORCLAMP(col[2] * GLGDDRAW_LIGHTEN); tmpCol[3] = col[3]; tmpXY[0] = xy[0] + 2.0f; tmpXY[1] = xy[1] + 2.0f; tmpWH[0] = wh[0] - 2.0f; tmpWH[1] = wh[1] - 2.0f; glgdDrawBoundary(tmpXY, tmpWH, tmpCol); break; default: break; } glgdPopAttributes(); } void glgdDrawSlider ( glgdDrawBoxType boxType, glgdDrawSliderType sliderType, glgdVec2 xy, glgdVec2 wh, glgdColor col1, glgdColor col2, GLdouble size, GLdouble val ) { GLdouble xsl, ysl, wsl, hsl; glgdDrawBoxType slBoxType; glgdVec2 pos, dim; glgdPushAttributes(); switch (sliderType) { case GLGDDRAW_SLIDERTYPE_VERT: case GLGDDRAW_SLIDERTYPE_VERT_NICE: hsl = size * (wh[1] - 2.0f * GLGDDRAW_BW1); ysl = glgdDrawLERP(1.0f - val, 0.0f, 1.0f, xy[1] + GLGDDRAW_BW1, xy[1] + wh[1] - GLGDDRAW_BW1 - hsl); wsl = wh[0] - 2.0f * GLGDDRAW_BW1; xsl = xy[0] + GLGDDRAW_BW1; break; case GLGDDRAW_SLIDERTYPE_HORIZ: case GLGDDRAW_SLIDERTYPE_HORIZ_NICE: wsl = size * (wh[0] - 2.0f * GLGDDRAW_BW1); xsl = glgdDrawLERP(val, 0.0f, 1.0f, xy[0] + GLGDDRAW_BW1, xy[0] + wh[0] - GLGDDRAW_BW1 - wsl); hsl = wh[1] - 2.0f * GLGDDRAW_BW1; ysl = xy[1] + GLGDDRAW_BW1; break; case GLGDDRAW_SLIDERTYPE_VERT_FILL: hsl = val * (wh[1] - 2.0f * GLGDDRAW_BW1); ysl = xy[1] + GLGDDRAW_BW1 + (1.0f - val) * (wh[1] - 2.0f * GLGDDRAW_BW1); wsl = wh[0] - 2.0f * GLGDDRAW_BW1; xsl = xy[0] + GLGDDRAW_BW1; break; case GLGDDRAW_SLIDERTYPE_HORIZ_FILL: wsl = val * (wh[0] - 2.0f * GLGDDRAW_BW1); xsl = xy[0] + GLGDDRAW_BW1; hsl = wh[1] - 2.0f * GLGDDRAW_BW1; ysl = xy[1] + GLGDDRAW_BW1; break; default: return; } /* Draw the slider */ glgdDrawBox(boxType, xy, wh, col1, GLGDDRAW_BW1); if (sliderType == GLGDDRAW_SLIDERTYPE_VERT_NICE) { pos[0] = xy[0] + wh[0] / 2.0f - 1.0f; pos[1] = xy[1] + GLGDDRAW_BW1; dim[0] = 2.0f; dim[1] = wh[1] - 2.0f * GLGDDRAW_BW1; glgdDrawBox(GLGDDRAW_BOXTYPE_FLAT, pos, dim, s_colorBlack, 0.0f); pos[0] = xsl; pos[1] = ysl; dim[0] = wsl; dim[1] = hsl; glgdDrawBox(GLGDDRAW_BOXTYPE_UP, pos, dim, col1, GLGDDRAW_BW1); pos[0] = xsl + 2.0f; pos[1] = ysl + hsl / 2.0f - 2.0f; dim[0] = wsl - 2.0f; dim[1] = 4.0f; glgdDrawBox(GLGDDRAW_BOXTYPE_DOWN, pos, dim, col2, 1.0f); } else if (sliderType == GLGDDRAW_SLIDERTYPE_HORIZ_NICE) { pos[0] = xy[0] + GLGDDRAW_BW1; pos[1] = xy[1] + wh[1] / 2.0f - 1.0f; dim[0] = wh[0] - 2.0f * GLGDDRAW_BW1; dim[1] = 2.0f; glgdDrawBox(GLGDDRAW_BOXTYPE_FLAT, pos, dim, s_colorBlack, 0.0f); pos[0] = xsl; pos[1] = ysl; dim[0] = wsl; dim[1] = hsl; glgdDrawBox(GLGDDRAW_BOXTYPE_UP, pos, dim, col1, GLGDDRAW_BW1); pos[0] = xsl + wsl / 2.0f - 2.0f; pos[1] = ysl + 1.0f; dim[0] = 4.0f; dim[1] = hsl - 2.0f; glgdDrawBox(GLGDDRAW_BOXTYPE_DOWN, pos, dim, col2, 1.0f); } else { switch (boxType) { case GLGDDRAW_BOXTYPE_UP: case GLGDDRAW_BOXTYPE_DOWN: slBoxType = GLGDDRAW_BOXTYPE_UP; break; case GLGDDRAW_BOXTYPE_FRAME: slBoxType = GLGDDRAW_BOXTYPE_FRAME; break; default: slBoxType = GLGDDRAW_BOXTYPE_BORDER; break; } pos[0] = xsl; pos[1] = ysl; dim[0] = wsl; dim[1] = hsl; glgdDrawBox(slBoxType, pos, dim, col2, GLGDDRAW_BW2); } glgdPopAttributes(); } gauche-gtk-0.6+git20160927/glgd/glgdDraw.h000066400000000000000000000045361300401456300176350ustar00rootroot00000000000000/* * glgdDraw.h * * OpenGL Graph Display primitive drawing module header file * * Written by: Shawn Taras */ #ifndef __GLGDDRAW_H__ #define __GLGDDRAW_H__ SCM_DECL_BEGIN /* * Enumerations */ typedef enum { GLGDDRAW_BOXTYPE_NONE = 0, GLGDDRAW_BOXTYPE_UP, GLGDDRAW_BOXTYPE_DOWN, GLGDDRAW_BOXTYPE_FLAT, GLGDDRAW_BOXTYPE_BORDER, GLGDDRAW_BOXTYPE_SHADOW, GLGDDRAW_BOXTYPE_FRAME, GLGDDRAW_BOXTYPE_COUNT } glgdDrawBoxType; typedef enum { GLGDDRAW_SLIDERTYPE_NONE = 0, GLGDDRAW_SLIDERTYPE_VERT, GLGDDRAW_SLIDERTYPE_VERT_FILL, GLGDDRAW_SLIDERTYPE_VERT_NICE, GLGDDRAW_SLIDERTYPE_HORIZ, GLGDDRAW_SLIDERTYPE_HORIZ_FILL, GLGDDRAW_SLIDERTYPE_HORIZ_NICE, GLGDDRAW_SLIDERTYPE_COUNT } glgdDrawSliderType; /* * Defines */ #define GLGDDRAW_COLORCLAMP(c) ((c) > 1.0f ? 1.0f : (c)) #define GLGDDRAW_LIGHTEN (1.5) #define GLGDDRAW_DARKEN (0.7) /* * Global Variables */ extern glgdColor g_colorBlack; extern glgdColor g_colorWhite; extern glgdColor g_colorRed; extern glgdColor g_colorGreen; extern glgdColor g_colorBlue; extern glgdColor g_colorYellow; extern glgdColor g_colorCyan; extern glgdColor g_colorMagenta; /* * Module API */ void glgdDrawZValueSet(GLdouble zValue); void glgdDrawZValueGet(GLdouble *zValue); void glgdDrawLineWidthSet(GLdouble lineWidth); void glgdDrawLineWidthGet(GLdouble *lineWidth); void glgdDrawLine(glgdVec2 xy, glgdVec2 wh, glgdColor col); void glgdDrawRect(glgdVec2 xy, glgdVec2 wh, glgdColor col); void glgdDrawBoundary(glgdVec2 xy, glgdVec2 wh, glgdColor col); void glgdDrawRectBoundary(glgdVec2 xy, glgdVec2 wh, glgdColor col); void glgdDrawQuad(glgdVec2 a, glgdVec2 b, glgdVec2 c, glgdVec2 d, glgdColor col); void glgdDrawQuadBoundary(glgdVec2 a, glgdVec2 b, glgdVec2 c, glgdVec2 d, glgdColor col); void glgdDrawBox(glgdDrawBoxType boxType, glgdVec2 xy, glgdVec2 wh, glgdColor col, GLdouble borderWidth); void glgdDrawSlider(glgdDrawBoxType boxType, glgdDrawSliderType sliderType, glgdVec2 xy, glgdVec2 wh, glgdColor col1, glgdColor col2, GLdouble size, GLdouble val); SCM_DECL_END #endif /* __GLGDDRAW_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdGraph.c000066400000000000000000001410221300401456300177640ustar00rootroot00000000000000/* * gldgGraph.c * * OpenGL Graph Display module implementation * * Written by: Shawn Taras */ #include #include #include #include #include "gauche-glgd.h" #include "glgd.h" /* * Defines */ #define GLGDGRAPH_DRAW_EXTENTS (0) #define GLGDGRAPH_CAMORBIT (0) #define GLGDGRAPH_NODENAME (1) #define GLGDGRAPH_LINKNAME (2) #ifdef __MINGW32__ #define _MAXFLT (HUGE_VAL) #else /*!__MINGW32__*/ #define _MAXFLT (HUGE) #endif /*!__MINGW32__*/ #define _PANGO_DPI (72) #define _PANGO_SCALE (3) #define _TEXW (1024) #define _TEXH (1024) /* * Static local (to this module) variables */ static glgdColor s_lineColor = {0.3, 0.3, 0.3, 1.0}; static glgdColor s_strokeColor = {0.1, 0.1, 0.1, 1.0}; static glgdVec2 s_strokePointSize = {6.0, 12.0}; static GLdouble s_lineWidth = 1.0; static GLint s_blendFunc[2] = {GL_ONE, GL_ZERO}; static GLint s_verbosity = 0; /* * Static local (to this module) functions */ static int glgdGraphChildInfo(glgdGraph *graph, glgdLink *link, int *childNdx) { int childCount; glgdLinkList *list; glgdLink *l; if (childNdx) { *childNdx = -1; } childCount = 0; list = graph->linkListHead; while (list) { l = list->linkHead; while (l) { if (childNdx && l == link) { *childNdx = childCount; } if (l->src == link->src) { childCount++; } l = l->next; } list = list->next; } glgdTrace(1, "glgdGraphChildInfo(graph, %s->%s, %d) = %d\n", link->src->label, link->dst->label, *childNdx, childCount); return childCount; } static GLboolean glgdGraphAutoOrganizeLinkList(glgdGraph *graph, glgdLinkList *list, glgdVec2 pos, glgdVec4 extents) { int childCount; int childNdx; GLdouble offset, width; glgdLink *link; glgdVec2 vec; GLboolean nextRow, nextCol; GLboolean srcValid, dstValid; if (graph != NULL) { glgdGraphNodeListFlag(graph, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_CLEAR); link = list->linkHead; while (link) { nextRow = GL_FALSE; srcValid = glgdBitfieldCompare(&graph->attributes, &link->src->attributes); dstValid = glgdBitfieldCompare(&graph->attributes, &link->dst->attributes); if (srcValid) { /* Source node */ if (srcValid) { if (glgdNodeIsTouched(link->src)) { if (glgdNodeIsTouched(link->dst) && dstValid) { glgdTrace(1, "LOOP: %s @ (%g,%g) to %s @ (%g,%g)\n", link->src->label, link->src->pos[0], link->src->pos[1], link->dst->label, link->dst->pos[0], link->dst->pos[1]); /* This link loops back to a parent node */ glgdLinkFlagsSet(link, GLGDLINK_FLAG_LOOPBACK, GLGD_FLAGOP_SET); } else { pos[0] = link->src->pos[0]; } } else { glgdTrace(1, "SRC: %s @ (%g,%g)\n", link->src->label, pos[0], pos[1]); glgdNodePosSet(link->src, pos, graph->dim, extents); glgdNodeFlagsSet(link->src, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_SET); nextRow = GL_TRUE; } } /* Destination node */ vec[0] = pos[0] + GLGD_QUARTER(graph->dim[0]); vec[1] = pos[1] - 1.25 * graph->dim[1]; if (dstValid) { if (glgdNodeIsTouched(link->dst) == GL_FALSE) { glgdTrace(1, "DST: %s @ (%g,%g)\n", link->dst->label, vec[0], vec[1]); glgdNodePosSet(link->dst, vec, graph->dim, extents); glgdNodeFlagsSet(link->dst, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_SET); nextRow = GL_TRUE; } } } link = link->next; if (nextRow) { pos[1] = vec[1]; } } glgdGraphNodeListFlag(graph, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_CLEAR); return GL_TRUE; } return GL_FALSE; } static void glgdGraphPushAttributes(void) { glPushAttrib(GL_ENABLE_BIT | GL_HINT_BIT | GL_LINE_BIT); glGetIntegerv(GL_BLEND_SRC, &s_blendFunc[0]); glGetIntegerv(GL_BLEND_DST, &s_blendFunc[1]); /* Common attributes for primitive drawing */ glDisable(GL_TEXTURE_2D); glDisable(GL_LIGHTING); glDisable(GL_DEPTH_TEST); glDisable(GL_CULL_FACE); glLineWidth((GLfloat)s_lineWidth); } static void glgdGraphPopAttributes(void) { glPopAttrib(); glBlendFunc(s_blendFunc[0], s_blendFunc[1]); } #ifdef HAVE_GLGD_PANGO static GLboolean glgdGraphNodeDrawLabel(glgdGraph *graph, glgdNode *node) { int i; GLint width; GLuint texture; GLfloat s0, s1, t0, t1; GLfloat a; guint32 alpha, rgb, *t; guint8 *row, *row_end; PangoContext *pangoContext; PangoFontDescription *fontDesc; PangoLayout *layout; PangoRectangle extents; FT_Bitmap bitmap; glgdVec2 center, pnt[2]; glgdStroke *stroke; glgdTexture *tex; if (graph && graph->pangoFT2Context) { stroke = &graph->stroke; tex = &graph->textTexture; if (tex->width <= 0 || tex->height <= 0) { glgdTrace(1, "Invalid texture dimension (%d,%d)\n", tex->width, tex->height); return GL_FALSE; } /* Pango font description */ width = 10 * _PANGO_SCALE; pangoContext = gtk_widget_get_pango_context(graph->gtkWindow); fontDesc = pango_context_get_font_description(pangoContext); pango_font_description_set_size(fontDesc, PANGO_SCALE * width); pango_font_description_set_weight(fontDesc, PANGO_WEIGHT_NORMAL); pango_context_set_font_description(graph->pangoFT2Context, fontDesc); /* Text layout */ width = (int)graph->dim[0] * _PANGO_SCALE; layout = graph->layout; pango_layout_set_width(layout, PANGO_SCALE * width); pango_layout_set_alignment(layout, PANGO_ALIGN_CENTER); pango_layout_set_text(layout, node->label, -1); pango_layout_get_extents(layout, NULL, &extents); if (extents.width == 0 || extents.height == 0) { glgdTrace(1, "Invalid extents (%d,%d)\n", extents.width, extents.height); return GL_FALSE; } /* Bitmap creation */ bitmap.rows = PANGO_PIXELS(extents.height); bitmap.width = PANGO_PIXELS(extents.width); if (bitmap.width > tex->width || bitmap.rows > tex->height) { return GL_FALSE; } bitmap.pitch = bitmap.width; bitmap.buffer = GLGD_MALLOC(bitmap.rows * bitmap.width); bitmap.num_grays = 256; bitmap.pixel_mode = ft_pixel_mode_grays; memset(bitmap.buffer, 0, bitmap.rows * bitmap.width); pango_ft2_render_layout(&bitmap, layout, PANGO_PIXELS(-extents.x), 0); #if !defined(GL_VERSION_1_2) && G_BYTE_ORDER == G_LITTLE_ENDIAN rgb =((guint32)(stroke->col[0] * 255.0)) | (((guint32)(stroke->col[1] * 255.0)) << 8) | (((guint32)(stroke->col[2] * 255.0)) << 16); #else rgb =(((guint32)(stroke->col[0] * 255.0)) << 24) | (((guint32)(stroke->col[1] * 255.0)) << 16) | (((guint32)(stroke->col[2] * 255.0)) << 8); #endif /* Bitmap transfer to */ a = stroke->col[3]; alpha = (guint32)(255.0 * a); row = bitmap.buffer + bitmap.rows * bitmap.width; row_end = bitmap.buffer; t = (guint32 *)tex->texels; if (graph->flags & GLGDGRAPH_FLAG_PANGOBOLD) { do { row -= bitmap.width; for (i=0; i 0) *t++ = rgb | (alpha << 24); else *t++ = rgb; #else if (row[i] > 0) *t++ = rgb | alpha; else *t++ = rgb; #endif } } while (row != row_end); } else { do { row -= bitmap.width; for (i=0; iname); #if !defined(GL_VERSION_1_2) glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, bitmap.width, bitmap.rows, GL_RGBA, GL_UNSIGNED_BYTE, tex->texels); #else glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, bitmap.width, bitmap.rows, GL_RGBA, GL_UNSIGNED_INT_8_8_8_8, tex->texels); #endif /* render */ s0 = 0.0; s1 = (GLdouble)bitmap.width / (GLdouble)tex->width; t0 = 0.0; t1 = (GLdouble)bitmap.rows / (GLdouble)tex->height; center[0] = node->pos[0] + GLGD_HALF(graph->dim[0]); center[1] = node->pos[1] + GLGD_HALF(graph->dim[1]); pnt[0][0] = center[0] - GLGD_HALF(bitmap.width / _PANGO_SCALE); pnt[0][1] = center[1] - GLGD_HALF(bitmap.rows / _PANGO_SCALE); pnt[1][0] = center[0] + GLGD_HALF(bitmap.width / _PANGO_SCALE); pnt[1][1] = center[1] + GLGD_HALF(bitmap.rows / _PANGO_SCALE); GLGD_FREE(bitmap.buffer); glColor3d(stroke->col[0], stroke->col[1], stroke->col[2]); glEnable(GL_TEXTURE_2D); glEnable(GL_BLEND); glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); glBindTexture(GL_TEXTURE_2D, tex->name); glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); glBegin(GL_QUADS); glTexCoord2f(s0, t0); glVertex3f(pnt[0][0], pnt[0][1], 0.0); glTexCoord2f(s0, t1); glVertex3f(pnt[0][0], pnt[1][1], 0.0); glTexCoord2f(s1, t1); glVertex3f(pnt[1][0], pnt[1][1], 0.0); glTexCoord2f(s1, t0); glVertex3f(pnt[1][0], pnt[0][1], 0.0); glEnd(); glDisable(GL_BLEND); glDisable(GL_TEXTURE_2D); return GL_TRUE; } return GL_FALSE; } #endif /* HAVE_GLGD_PANGO */ static GLboolean glgdGraphNodeRender ( glgdGraph *graph, glgdNode *node, ScmObj fn, GLenum renderMode ) { if (renderMode == GL_SELECT) { glPushName(GLGDGRAPH_NODENAME); } glgdNodeDraw(node, graph->dim, fn, renderMode); if (renderMode == GL_SELECT) { glPopName(); } #ifdef HAVE_GLGD_PANGO glgdGraphNodeDrawLabel(graph, node); #endif /* HAVE_GLGD_PANGO */ return GL_TRUE; } static GLboolean glgdGraphRender(glgdGraph *graph, GLenum renderMode) { int linkNdx; int nodeDrawCount; glgdLinkList *list; glgdLink *link; glgdNode *src; glgdNode *dst; ScmObj fn; if (graph != NULL) { fn = NULL; if (renderMode == GL_RENDER) { fn = graph->fn[GLGDGRAPH_FN_PRERENDER]; } glgdGraphNodeListFlag(graph, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_CLEAR); linkNdx = 0; list = graph->linkListHead; while (list) { link = list->linkHead; while (link) { src = link->src; dst = link->dst; nodeDrawCount = 0; if (glgdBitfieldCompare(&graph->attributes, &src->attributes)) { /* Draw the src node */ if (glgdNodeIsTouched(src) == GL_FALSE) { glgdGraphNodeRender(graph, src, fn, renderMode); glgdNodeFlagsSet(src, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_SET); } nodeDrawCount++; if (!(link->flags & GLGDLINK_FLAG_LONER) && glgdBitfieldCompare(&graph->attributes, &dst->attributes)) { if (glgdNodeIsTouched(dst) == GL_FALSE) { glgdGraphNodeRender(graph, dst, fn, renderMode); glgdNodeFlagsSet(dst, GLGDNODE_FLAG_TOUCHED, GLGD_FLAGOP_SET); } nodeDrawCount++; } } if (nodeDrawCount == 2) { /* Draw the connecting link */ if (renderMode == GL_SELECT) { glPushName(GLGDGRAPH_LINKNAME); glPushName(linkNdx); } glColor4d(graph->lineColor[0], graph->lineColor[1], graph->lineColor[2], graph->lineColor[3]); glgdLinkDraw(link, graph->dim, renderMode); if (renderMode == GL_SELECT) { glPopName(); glPopName(); } } link = link->next; linkNdx++; } list = list->next; } return GL_TRUE; } return GL_FALSE; } static void glgdGraphComputeHoverData(glgdGraph *graph, GLdouble mx, GLdouble my) { int i, j; GLint nameCount; GLint hitCount; GLuint selectBuf[64]; GLuint *ptr; if (graph->nodeHead) { glSelectBuffer(64, selectBuf); glRenderMode(GL_SELECT); glInitNames(); glgdGraphPushAttributes(); glgdCamBeginPick(&graph->ctrlCam, mx, my); glgdGraphRender(graph, GL_SELECT); glgdCamEnd(&graph->ctrlCam); glgdGraphPopAttributes(); glFlush(); hitCount = glRenderMode(GL_RENDER); if (hitCount > 0) { ptr = &selectBuf[0]; for (i=0; ihoverNode = glgdNodeByID(graph->nodeHead, ptr[1]); graph->hoverLink = NULL; } else if (*ptr == GLGDGRAPH_LINKNAME) { graph->hoverLink = glgdGraphLinkByNdx(graph, ptr[1]); if (nameCount > 2) { graph->hoverNode = glgdNodeByID(graph->nodeHead, ptr[2]); } } if (s_verbosity >= 3) { for (j=0; jhoverNode = NULL; graph->hoverLink = NULL; } } } static gboolean glgdGraphMouseButtonCB(GtkWidget *widget, GdkEventButton *event, gpointer *data) { ScmObj fn; glgdGraph *graph; graph = (glgdGraph *)data; if (graph == NULL) { return FALSE; } switch (event->type) { case GDK_BUTTON_PRESS: glgdCamMouseSet(&graph->ctrlCam, event->x, event->y); break; case GDK_BUTTON_RELEASE: glgdCamMouseSet(&graph->ctrlCam, -1.0, -1.0); break; default: return FALSE; } gdk_window_invalidate_rect(widget->window, &widget->allocation, FALSE); fn = graph->fn[GLGDGRAPH_FN_MOUSE_LEFT]; if (fn && event->button == 1) { Scm_ApplyRec4(fn, SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)), SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)), SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)), SCM_OBJ(Scm_MakeGdkEventButton(event))); } fn = graph->fn[GLGDGRAPH_FN_MOUSE_MIDDLE]; if (fn && event->button == 2) { Scm_ApplyRec4(fn, SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)), SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)), SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)), SCM_OBJ(Scm_MakeGdkEventButton(event))); } fn = graph->fn[GLGDGRAPH_FN_MOUSE_RIGHT]; if (fn && event->button == 3) { Scm_ApplyRec4(fn, SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)), SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)), SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)), SCM_OBJ(Scm_MakeGdkEventButton(event))); } return TRUE; } static gboolean glgdGraphMouseMotionCB(GtkWidget *widget, GdkEventMotion *event, gpointer *data) { int ix, iy; GLdouble x, y; GdkModifierType state; ScmObj fn; glgdGraph *graph; graph = (glgdGraph *)data; if (graph == NULL) { return FALSE; } /* Process the GDK_POINTER_MOTION_HINT_MASK events */ if (event->is_hint) { gdk_window_get_pointer(event->window, &ix, &iy, &state); x = (GLdouble)ix; y = (GLdouble)iy; } else { x = event->x; y = event->y; state = event->state; } if (state & GDK_BUTTON1_MASK) { if (state & GDK_BUTTON2_MASK) { if (graph->flags & GLGDGRAPH_FLAG_CTRLHELD) { glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_ZOOM, x, y, graph->frameTime); } } #if GLGDGRAPH_CAMORBIT else { if (graph->flags & GLGDGRAPH_FLAG_CTRLHELD) { glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_ORBIT, x, y, graph->frameTime); } } #endif /* GLGDGRAPH_CAMORBIT */ } else if (state & GDK_BUTTON2_MASK) { if (graph->flags & GLGDGRAPH_FLAG_CTRLHELD) { glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_PAN, x, y, graph->frameTime); } #if !GLGDGRAPH_CAMORBIT else { glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_PAN, x, y, graph->frameTime); } #endif /* !GLGDGRAPH_CAMORBIT */ } else if (state & GDK_BUTTON3_MASK) { if (graph->flags & GLGDGRAPH_FLAG_CTRLHELD) { glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_ZOOM, x, y, graph->frameTime); } } fn = graph->fn[GLGDGRAPH_FN_MOUSE_HOVER]; if (fn) { Scm_ApplyRec4(fn, SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)), SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)), SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)), SCM_OBJ(Scm_MakeGdkEventMotion(event))); } gdk_window_invalidate_rect(widget->window, &widget->allocation, FALSE); return TRUE; } static gboolean glgdGraphMouseScrollCB(GtkWidget *widget, GdkEventScroll *event, gpointer *data) { glgdGraph *graph; ScmObj fn; graph = (glgdGraph *)data; if (graph == NULL) { return FALSE; } switch (event->direction) { case GDK_SCROLL_UP: glgdCamMouseSet(&graph->ctrlCam, event->x, event->y); glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_ZOOM, event->x + 50.0, event->y, graph->frameTime); break; case GDK_SCROLL_DOWN: glgdCamMouseSet(&graph->ctrlCam, event->x, event->y); glgdCamUpdate(&graph->ctrlCam, GLGDCAM_MODE_ZOOM, event->x - 50.0, event->y, graph->frameTime); break; default: return FALSE; } gdk_window_invalidate_rect(widget->window, &widget->allocation, FALSE); fn = graph->fn[GLGDGRAPH_FN_MOUSE_SCROLL]; if (fn) { Scm_ApplyRec4(fn, SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)), SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)), SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)), SCM_OBJ(Scm_MakeGdkEventScroll(event))); } return TRUE; } static gboolean glgdGraphKeyCB(GtkWidget *widget, GdkEventKey *event, gpointer data) { glgdGraph *graph; ScmObj keyFn; graph = (glgdGraph *)data; if (graph == NULL) { return FALSE; } switch (event->keyval) { case GDK_Control_L: case GDK_Control_R: if (event->type == GDK_KEY_PRESS) { graph->flags |= GLGDGRAPH_FLAG_CTRLHELD; } else if (event->type == GDK_KEY_RELEASE) { graph->flags &= ~GLGDGRAPH_FLAG_CTRLHELD; } break; case GDK_Escape: if (event->type == GDK_KEY_PRESS) { graph->flags |= GLGDGRAPH_FLAG_ESCPRESSED; } break; default: return FALSE; } gdk_window_invalidate_rect(widget->window, &widget->allocation, FALSE); keyFn = graph->fn[GLGDGRAPH_FN_KEY]; if (keyFn != NULL) { Scm_ApplyRec4(keyFn, SCM_OBJ(SCM_MAKE_GLGD_GRAPH(graph)), SCM_OBJ(SCM_MAKE_GLGD_NODE(graph->hoverNode)), SCM_OBJ(SCM_MAKE_GLGD_LINK(graph->hoverLink)), SCM_OBJ(Scm_MakeGdkEventKey(event))); } return TRUE; } /* NB: this is here only because we need glgdGraphConnect3 to keep backward compatibility; once glgdGraphConnect3 is gone, we can merge this into glgdGraphConnect. */ static GLboolean glgdGraphConnectInt(glgdGraph *graph, GtkWidget *gtkWindow, GtkWidget *glDrawArea) { if (graph && gtkWindow && glDrawArea) { /* Add mouse and keyboard events to the GL draw area */ gtk_widget_add_events(glDrawArea, GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_SCROLL_MASK | GDK_VISIBILITY_NOTIFY_MASK); /* Connect signals to callback routines */ g_signal_connect(G_OBJECT(glDrawArea), "button_press_event", G_CALLBACK(glgdGraphMouseButtonCB), graph); g_signal_connect(G_OBJECT(glDrawArea), "button_release_event", G_CALLBACK(glgdGraphMouseButtonCB), graph); g_signal_connect(G_OBJECT(glDrawArea), "motion_notify_event", G_CALLBACK(glgdGraphMouseMotionCB), graph); g_signal_connect(G_OBJECT(glDrawArea), "scroll_event", G_CALLBACK(glgdGraphMouseScrollCB), graph); /* GTK_CAN_FOCUS allows the to receive key events */ GTK_WIDGET_SET_FLAGS(glDrawArea, GTK_CAN_FOCUS); g_signal_connect(G_OBJECT(glDrawArea), "key_press_event", G_CALLBACK(glgdGraphKeyCB), graph); g_signal_connect(G_OBJECT(glDrawArea), "key_release_event", G_CALLBACK(glgdGraphKeyCB), graph); graph->gtkWindow = gtkWindow; graph->gtkGLDrawArea = glDrawArea; #ifdef HAVE_GLGD_PANGO graph->pangoFT2Context = pango_ft2_get_context(_PANGO_DPI, _PANGO_DPI); if (graph->pangoFT2Context == NULL) { printf("pango_ft2_get_context(%d,%d) failed\n", _PANGO_DPI, _PANGO_DPI); glgdGraphFini(graph); return GL_FALSE; } graph->layout = pango_layout_new(graph->pangoFT2Context); #endif /* HAVE_GLGD_PANGO */ return GL_TRUE; } return GL_FALSE; } /* * External public functions */ glgdGraph *glgdGraphCreate(void) { glgdGraph *graph; graph = (glgdGraph *)GLGD_MALLOC(sizeof(glgdGraph)); if (graph) { glgdGraphInit(graph); } return graph; } glgdGraph *glgdGraphDestroy(glgdGraph *graph) { glgdGraphFini(graph); GLGD_FREE(graph); return (glgdGraph *)NULL; } GLboolean glgdGraphInit(glgdGraph *graph) { int i; if (graph != NULL) { graph->flags = GLGDGRAPH_FLAG_INITIALIZED; graph->nodeCount = 0; graph->linkCount = 0; graph->frameTime = 1.0 / 30.0; graph->margin = GLGDGRAPH_NODEMARGIN_DEFAULT; graph->dim[0] = GLGDGRAPH_NODEWIDTH_DEFAULT; graph->dim[1] = GLGDGRAPH_NODEHEIGHT_DEFAULT; graph->extents[0] = +_MAXFLT; graph->extents[1] = +_MAXFLT; graph->extents[2] = -_MAXFLT; graph->extents[3] = -_MAXFLT; glgdGraphLineColorSet(graph, s_lineColor); glgdCamInit(&graph->ctrlCam); glgdStrokeInit(&graph->stroke); graph->stroke.flags |= GLGDSTROKE_FLAG_INVERT; glgdStrokeColorSet(&graph->stroke, s_strokeColor); glgdStrokePointSizeSet(&graph->stroke, s_strokePointSize); glgdBitfieldInit(&graph->attributes); graph->nodeHead = NULL; graph->linkListHead = NULL; graph->hoverNode = NULL; graph->hoverLink = NULL; graph->timer = g_timer_new(); graph->gtkWindow = NULL; graph->gtkGLDrawArea = NULL; for (i=0; ifn[i] = NULL; } #ifdef HAVE_GLGD_PANGO graph->pangoFT2Context = NULL; glgdTextureInit(&graph->textTexture); #endif /* HAVE_GLGD_PANGO */ return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphFini(glgdGraph *graph) { if (graph != NULL) { if (graph->nodeHead) { glgdNodeDestroy(graph->nodeHead); } glgdStrokeFini(&graph->stroke); glgdBitfieldFini(&graph->attributes); g_timer_destroy(graph->timer); #ifdef HAVE_GLGD_PANGO glgdTextureFini(&graph->textTexture); if (graph->pangoFT2Context != NULL) { g_object_unref(G_OBJECT(graph->pangoFT2Context)); pango_ft2_shutdown_display(); graph->pangoFT2Context = NULL; } if (graph->layout != NULL) { g_object_unref(G_OBJECT(graph->layout)); graph->layout = NULL; } #endif /* HAVE_GLGD_PANGO */ graph->flags = GLGDGRAPH_FLAG_INITIALIZED; graph->nodeCount = 0; graph->linkCount = 0; graph->frameTime = 1.0 / 30.0; graph->margin = GLGDGRAPH_NODEMARGIN_DEFAULT; graph->dim[0] = GLGDGRAPH_NODEWIDTH_DEFAULT; graph->dim[1] = GLGDGRAPH_NODEHEIGHT_DEFAULT; graph->extents[0] = +_MAXFLT; graph->extents[1] = +_MAXFLT; graph->extents[2] = -_MAXFLT; graph->extents[3] = -_MAXFLT; glgdGraphLineColorSet(graph, s_lineColor); glgdCamInit(&graph->ctrlCam); glgdStrokeInit(&graph->stroke); graph->stroke.flags |= GLGDSTROKE_FLAG_INVERT; glgdStrokeColorSet(&graph->stroke, s_strokeColor); glgdStrokePointSizeSet(&graph->stroke, s_strokePointSize); glgdBitfieldInit(&graph->attributes); graph->nodeHead = NULL; graph->linkListHead = NULL; graph->hoverNode = NULL; graph->hoverLink = NULL; graph->timer = g_timer_new(); graph->gtkWindow = NULL; graph->gtkGLDrawArea = NULL; } return GL_FALSE; } GLboolean glgdGraphDraw(glgdGraph *graph) { int ix, iy; GLdouble aspect; GLdouble w, h; GLdouble x, y; GdkModifierType state; glgdStroke *last; glgdLink *link; if (graph != NULL) { if (graph->gtkGLDrawArea && graph->ctrlCam.winDim[0] == 0.0 && graph->ctrlCam.winDim[1] == 0.0) { w = (GLdouble)graph->gtkGLDrawArea->allocation.width; h = (GLdouble)graph->gtkGLDrawArea->allocation.height; glViewport(0, 0, graph->gtkGLDrawArea->allocation.width, graph->gtkGLDrawArea->allocation.height); /* Submit the window dimension to the stroke font */ glgdStrokeWindowDimSetByList(&graph->stroke, w, h); /* Set up the camera frustum wrt window dimensions */ aspect = h / w; glgdCamFrustum(&graph->ctrlCam, -1.0, 1.0, -aspect, aspect, 4.0, 8000.0); glgdCamWinDimSet(&graph->ctrlCam, w, h); glgdCamFrame(&graph->ctrlCam, graph->extents[0], graph->extents[2] + graph->margin, graph->extents[1], graph->extents[3] + graph->margin); } #ifdef HAVE_GLGD_PANGO if (graph->textTexture.texels == NULL) { if (glgdTextureSetup(&graph->textTexture, _TEXW, _TEXH) == GL_FALSE) { printf("glgdTextureSetup(%d,%d) failed\n", _TEXW, _TEXH); return GL_FALSE; } } #endif /* HAVE_GLGD_PANGO */ if (graph->nodeHead) { last = glgdStrokeGetCurrent(); glgdStrokeSetCurrent(&graph->stroke); glgdGraphPushAttributes(); glgdCamBegin(&graph->ctrlCam); glgdGraphRender(graph, GL_RENDER); glgdStrokeSetCurrent(last); #if GLGDGRAPH_DRAW_EXTENTS /* Draw Extents */ { glgdVec2 xy; glgdVec2 wh; xy[0] = graph->extents[0]; xy[1] = graph->extents[1]; wh[0] = graph->extents[2] - xy[0]; wh[1] = graph->extents[3] - xy[1]; glgdDrawBoundary(xy, wh, g_colorYellow); xy[0] = -graph->ctrlCam.camPos[0] - 2.0; xy[1] = -graph->ctrlCam.camPos[1] - 2.0; wh[0] = 4.0; wh[1] = 4.0; glgdDrawRect(xy, wh, g_colorRed); } #endif /* GLGDGRAPH_DRAW_EXTENTS */ glgdCamEnd(&graph->ctrlCam); glgdGraphPopAttributes(); if (graph->gtkWindow) { gdk_window_get_pointer(graph->gtkWindow->window, &ix, &iy, &state); x = (GLdouble)ix; y = (GLdouble)iy; glgdGraphComputeHoverData(graph, x, y); } } g_timer_stop(graph->timer); graph->frameTime = g_timer_elapsed(graph->timer, NULL); g_timer_start(graph->timer); return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphFrame(glgdGraph *graph) { if (graph != NULL) { return glgdCamFrame(&graph->ctrlCam, graph->extents[0], graph->extents[2] + graph->margin, graph->extents[1], graph->extents[3] + graph->margin); } return GL_FALSE; } GLboolean glgdGraphInvalidate(glgdGraph *graph) { if (graph != NULL) { if (graph->gtkGLDrawArea) { gdk_window_invalidate_rect(graph->gtkGLDrawArea->window, &graph->gtkGLDrawArea->allocation, FALSE); return GL_TRUE; } } return GL_FALSE; } GLboolean glgdGraphReshape(glgdGraph *graph) { if (graph != NULL) { /* will recompute the viewport */ graph->ctrlCam.winDim[0] = 0.0; graph->ctrlCam.winDim[1] = 0.0; return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphConnect(glgdGraph *graph, GtkWidget *glDrawArea) { return glgdGraphConnectInt(graph, gtk_widget_get_toplevel(glDrawArea), glDrawArea); } GLboolean glgdGraphConnect3(glgdGraph *graph, GtkWidget *gtkWindow, ScmObj glDrawArea) { if (!SCM_GTK_WIDGET_P(glDrawArea)) { Scm_Error(" required, but got %S", glDrawArea); } return glgdGraphConnectInt(graph, gtkWindow, SCM_GTK_WIDGET(glDrawArea)); } GLboolean glgdGraphTranslate(glgdGraph *graph, GLdouble x, GLdouble y) { glgdVec2 xlat; if (graph != NULL) { graph->extents[0] = +_MAXFLT; graph->extents[1] = +_MAXFLT; graph->extents[2] = -_MAXFLT; graph->extents[3] = -_MAXFLT; xlat[0] = x; xlat[1] = y; return glgdNodeTranslate(graph->nodeHead, xlat, graph->dim, graph->extents); } return GL_FALSE; } GLboolean glgdGraphCenter(glgdGraph *graph) { glgdVec2 xlat; if (graph != NULL) { xlat[0] = -GLGD_HALF(graph->extents[0] + graph->extents[2]); xlat[1] = -GLGD_HALF(graph->extents[1] + graph->extents[3]); return glgdGraphTranslate(graph, xlat[0], xlat[1]); } return GL_FALSE; } GLboolean glgdGraphAutoOrganize(glgdGraph *graph, glgdVec2 pos) { GLboolean rc; glgdVec2 org; glgdLinkList *list; if (graph && graph->nodeHead) { graph->extents[0] = +_MAXFLT; graph->extents[1] = +_MAXFLT; graph->extents[2] = -_MAXFLT; graph->extents[3] = -_MAXFLT; org[0] = pos[0]; org[1] = pos[1]; list = graph->linkListHead; while (list) { glgdGraphAutoOrganizeLinkList(graph, list, pos, graph->extents); /* Next graph is to the right of the last */ pos[0] = graph->extents[2] + graph->margin; pos[1] = org[1]; list = list->next; } } return GL_FALSE; } GLboolean glgdGraphAutoOrganizeXY ( glgdGraph *graph, GLdouble x, GLdouble y ) { glgdVec2 pos; pos[0] = x; pos[1] = y; return glgdGraphAutoOrganize(graph, pos); } glgdNode *glgdGraphNodeByID(glgdGraph *graph, int nodeID) { return glgdNodeByID(graph->nodeHead, nodeID); } glgdNode *glgdGraphNodeSelected(glgdGraph *graph, int selectNdx) { int ndx; glgdNode *node; node = NULL; if (graph && selectNdx >= 0 && selectNdx < glgdGraphNodeSelectCount(graph)) { ndx = 0; node = graph->nodeHead; while (node) { if (glgdNodeIsSelected(node)) { if (ndx == selectNdx) { return node; } ndx++; } node = node->next; } } return node; } int glgdGraphNodeSelectCount(glgdGraph *graph) { int nodeSelectCount; glgdNode *node; nodeSelectCount = 0; if (graph != NULL) { node = graph->nodeHead; while (node) { if (glgdNodeIsSelected(node)) { nodeSelectCount++; } node = node->next; } } return nodeSelectCount; } int glgdGraphNodeCount(glgdGraph *graph) { int nodeCount; glgdNode *node; nodeCount = 0; if (graph != NULL) { node = graph->nodeHead; while (node) { nodeCount++; node = node->next; } } return nodeCount; } GLboolean glgdGraphNodeAdd(glgdGraph *graph, glgdNode *node) { glgdNode *n; GLboolean done; /* Add to the list sorted by */ if (graph && node) { if (graph->nodeHead == NULL) { graph->nodeHead = node; } else { n = graph->nodeHead; done = GL_FALSE; while (!done) { if (node->id <= n->id) { /* Pre-insert */ node->next = n; node->prev = n->prev; if (n->prev != NULL) { n->prev->next = node; } else { graph->nodeHead = node; } n->prev = node; done = GL_TRUE; } else if (n->next == NULL) { /* Add to end of list */ n->next = node; node->prev = n; done = GL_TRUE; } n = n->next; } } graph->nodeCount++; return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphLinkListAdd(glgdGraph *graph, glgdLinkList *list) { glgdLinkList *l; if (graph && list) { if (graph->linkListHead == NULL) { graph->linkListHead = list; } else { l = graph->linkListHead; while (l->next != NULL) { l = l->next; } l->next = list; } return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphLinkListDump(glgdGraph *graph) { if (graph != NULL) { glgdLinkListDump(graph->linkListHead); } return GL_FALSE; } GLboolean glgdGraphNodeListFlag(glgdGraph *graph, GLuint flagMask, glgdFlagOp flagOp) { glgdNode *node; if (graph != NULL) { node = graph->nodeHead; while (node) { glgdNodeFlagsSet(node, flagMask, flagOp); node = node->next; } return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphLinkAdd(glgdGraph *graph, glgdLinkList *list, glgdLink *link) { glgdLink *l; GLboolean done; GLboolean inserted; /* Add to the list sorted by src->dst relationship */ if (graph && list && link) { if (link->src == link->dst) { if (list->linkHead == NULL) { list->linkHead = link; glgdLinkFlagsSet(link, GLGDLINK_FLAG_LONER, GLGD_FLAGOP_SET); glgdTrace(1, "list->linkHead = [%s->%s] ***LONER***\n", link->src->label, link->dst->label); graph->linkCount++; return GL_TRUE; } else { printf("Error! Attempt to add LONER to non-empty list\n"); return GL_FALSE; } } if (list->linkHead && (list->linkHead->flags & GLGDLINK_FLAG_LONER)) { printf("Error! Attempt to add link to a LONER list\n"); return GL_FALSE; } if (list->linkHead == NULL) { list->linkHead = link; glgdTrace(1, "list->linkHead = [%s->%s]\n", link->src->label, link->dst->label); } else { /* First Pass: Post-insert */ l = list->linkHead; done = GL_FALSE; inserted = GL_FALSE; while (!done) { if (l->dst == link->src) { /* Post-insert */ link->next = l->next; if (l->next) { l->next->prev = link; } link->prev = l; l->next = link; glgdTrace(1, "[%s->%s] AFTER [%s->%s]\n", link->src->label, link->dst->label, l->src->label, l->dst->label); inserted = GL_TRUE; done = GL_TRUE; } else if (l->next == NULL) { done = GL_TRUE; } l = l->next; } /* Second Pass: Pre-insert and append */ if (inserted == GL_FALSE) { l = list->linkHead; done = GL_FALSE; while (!done) { if (l->src == link->src || l->src == link->dst) { /* Pre-insert */ link->next = l; link->prev = l->prev; if (l->prev != NULL) { l->prev->next = link; } else { list->linkHead = link; } l->prev = link; glgdTrace(1, "[%s->%s] BEFORE [%s->%s]\n", link->src->label, link->dst->label, l->src->label, l->dst->label); done = GL_TRUE; } else if (l->next == NULL) { /* Add to end of list */ l->next = link; link->prev = l; glgdTrace(1, "[%s->%s] AFTER [%s->%s] AT END\n", link->src->label, link->dst->label, l->src->label, l->dst->label); done = GL_TRUE; } l = l->next; } } } graph->linkCount++; return GL_TRUE; } return GL_FALSE; } int glgdGraphLinkNdx(glgdGraph *graph, glgdLink *link) { int linkNdx; glgdLinkList *list; glgdLink *l; if (graph && link) { linkNdx = 0; list = graph->linkListHead; while (list) { l = list->linkHead; while (l) { if (l == link) { return linkNdx; } l = l->next; linkNdx++; } list = list->next; } } return -1; } glgdLink *glgdGraphLinkByNdx(glgdGraph *graph, int linkNdx) { int curNdx; glgdLinkList *list; glgdLink *l; if (graph && linkNdx >= 0) { curNdx = 0; list = graph->linkListHead; while (list) { l = list->linkHead; while (l) { if (curNdx == linkNdx) { return l; } l = l->next; curNdx++; } list = list->next; } } return NULL; } GLboolean glgdGraphCallbackSet(glgdGraph *graph, glgdGraphFnEnum type, ScmObj fn) { if (graph && type >= 0 && type < GLGDGRAPH_FN_COUNT) { graph->fn[type] = fn; return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphFlagsSet(glgdGraph *graph, GLuint flagMask, glgdFlagOp op) { if (graph && op < GLGD_FLAGOP_COUNT) { if (op == GLGD_FLAGOP_CLEAR) { graph->flags &= ~flagMask; } else if (op == GLGD_FLAGOP_SET) { graph->flags |= flagMask; } else if (op == GLGD_FLAGOP_TOGGLE) { graph->flags ^= flagMask; } return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphDimSet(glgdGraph *graph, glgdVec2 dim) { if (graph != NULL) { graph->dim[0] = dim[0]; graph->dim[1] = dim[1]; } return GL_FALSE; } GLboolean glgdGraphDimSetByList(glgdGraph *graph, GLdouble w, GLdouble h) { if (graph != NULL) { graph->dim[0] = w; graph->dim[1] = h; } return GL_FALSE; } GLboolean glgdGraphDimGet(glgdGraph *graph, glgdVec2 dim) { if (graph && dim) { dim[0] = graph->dim[0]; dim[1] = graph->dim[1]; } return GL_FALSE; } GLboolean glgdGraphMarginSet(glgdGraph *graph, GLdouble margin) { if (graph != NULL) { graph->margin = margin; } return GL_FALSE; } GLdouble glgdGraphMarginGet(glgdGraph *graph) { GLdouble nodeMargin; if (graph) { return graph->margin; } return GLGDGRAPH_NODEMARGIN_DEFAULT; } GLboolean glgdGraphLineColorSet(glgdGraph *graph, glgdColor col) { if (graph && col) { graph->lineColor[0] = col[0]; graph->lineColor[1] = col[1]; graph->lineColor[2] = col[2]; graph->lineColor[3] = col[3]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphLineColorSetByList ( glgdGraph *graph, GLdouble r, GLdouble g, GLdouble b, GLdouble a ) { if (graph) { graph->lineColor[0] = r; graph->lineColor[1] = g; graph->lineColor[2] = b; graph->lineColor[3] = a; return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphLineColorGet(glgdGraph *graph, glgdColor col) { if (graph && col) { col[0] = graph->lineColor[0]; col[1] = graph->lineColor[1]; col[2] = graph->lineColor[2]; col[3] = graph->lineColor[3]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdGraphAttributeClear(glgdGraph *graph) { if (graph != NULL) { return glgdBitfieldClear(&graph->attributes); } return GL_FALSE; } GLboolean glgdGraphAttributeSet(glgdGraph *graph, int attrNdx) { if (graph != NULL) { return glgdBitfieldSet(&graph->attributes, attrNdx); } return GL_FALSE; } GLboolean glgdGraphAttributeToggle(glgdGraph *graph, int attrNdx) { if (graph != NULL) { return glgdBitfieldToggle(&graph->attributes, attrNdx); } return GL_FALSE; } GLboolean glgdGraphAttributeReset(glgdGraph *graph, int attrNdx) { if (graph != NULL) { return glgdBitfieldReset(&graph->attributes, attrNdx); } return GL_FALSE; } GLboolean glgdGraphAttributeIsSet(glgdGraph *graph, int attrNdx) { if (graph != NULL) { return glgdBitfieldIsSet(&graph->attributes, attrNdx); } return GL_FALSE; } int glgdVerbosity(int verbosity) { if (verbosity >= 0) { s_verbosity = verbosity; } return s_verbosity; } int glgdTrace(int verbosity, const char *fmt, ...) { va_list ap; if (s_verbosity >= verbosity) { va_start(ap, fmt); vprintf(fmt, ap); va_end(ap); } } gauche-gtk-0.6+git20160927/glgd/glgdGraph.h000066400000000000000000000104751300401456300200000ustar00rootroot00000000000000/* * gldgGraph.h * * OpenGL Graph Display module header file * * Written by: Shawn Taras */ #ifndef __GLGDGRAPH_H__ #define __GLGDGRAPH_H__ SCM_DECL_BEGIN /* * Enumerations */ typedef enum { GLGDGRAPH_FN_MOUSE_LEFT = 0, GLGDGRAPH_FN_MOUSE_MIDDLE, GLGDGRAPH_FN_MOUSE_RIGHT, GLGDGRAPH_FN_MOUSE_SCROLL, GLGDGRAPH_FN_MOUSE_HOVER, GLGDGRAPH_FN_KEY, GLGDGRAPH_FN_PRERENDER, GLGDGRAPH_FN_COUNT } glgdGraphFnEnum; /* * Defines */ #define GLGDGRAPH_FLAG_INITIALIZED (0x0001) #define GLGDGRAPH_FLAG_CTRLHELD (0x0002) #define GLGDGRAPH_FLAG_ESCPRESSED (0x0004) #define GLGDGRAPH_FLAG_PANGOBOLD (0x0008) #define GLGDGRAPH_NODEMARGIN_DEFAULT ( 16.0) #define GLGDGRAPH_NODEWIDTH_DEFAULT (106.0) #define GLGDGRAPH_NODEHEIGHT_DEFAULT ( 23.0) /* * Type Definitions */ typedef struct _glgdGraph { GLbitfield flags; int nodeCount; int linkCount; GLdouble frameTime; GLdouble margin; glgdVec2 dim; glgdVec4 extents; /* [minX, minY, maxX, maxY] */ glgdColor lineColor; glgdCam ctrlCam; glgdStroke stroke; glgdBitfield attributes; glgdNode *nodeHead; glgdLinkList *linkListHead; glgdNode *hoverNode; glgdLink *hoverLink; GTimer *timer; GtkWidget *gtkWindow; GtkWidget *gtkGLDrawArea; ScmObj fn[GLGDGRAPH_FN_COUNT]; #ifdef HAVE_GLGD_PANGO PangoContext *pangoFT2Context; glgdTexture textTexture; PangoLayout *layout; #endif /* HAVE_GLGD_PANGO */ } glgdGraph; /* * Module API */ glgdGraph *glgdGraphCreate(void); glgdGraph *glgdGraphDestroy(glgdGraph *graph); GLboolean glgdGraphInit(glgdGraph *graph); GLboolean glgdGraphFini(glgdGraph *graph); GLboolean glgdGraphDraw(glgdGraph *graph); GLboolean glgdGraphFrame(glgdGraph *graph); GLboolean glgdGraphInvalidate(glgdGraph *graph); GLboolean glgdGraphReshape(glgdGraph *graph); GLboolean glgdGraphConnect(glgdGraph *graph, GtkWidget *glDrawArea); GLboolean glgdGraphTranslate(glgdGraph *graph, GLdouble x, GLdouble y); GLboolean glgdGraphCenter(glgdGraph *graph); GLboolean glgdGraphAutoOrganize(glgdGraph *graph, glgdVec2 pos); GLboolean glgdGraphAutoOrganizeXY(glgdGraph *graph, GLdouble x, GLdouble y); glgdNode *glgdGraphNodeByID(glgdGraph *graph, int nodeID); glgdNode *glgdGraphNodeSelected(glgdGraph *graph, int selectNdx); int glgdGraphNodeSelectCount(glgdGraph *graph); int glgdGraphNodeCount(glgdGraph *graph); GLboolean glgdGraphNodeAdd(glgdGraph *graph, glgdNode *node); GLboolean glgdGraphNodeListFlag(glgdGraph *graph, GLuint flagMask, glgdFlagOp flagOp); GLboolean glgdGraphLinkListAdd(glgdGraph *graph, glgdLinkList *list); GLboolean glgdGraphLinkListDump(glgdGraph *graph); GLboolean glgdGraphLinkAdd(glgdGraph *graph, glgdLinkList *list, glgdLink *link); int glgdGraphLinkNdx(glgdGraph *graph, glgdLink *link); glgdLink *glgdGraphLinkByNdx(glgdGraph *graph, int linkNdx); GLboolean glgdGraphCallbackSet(glgdGraph *graph, glgdGraphFnEnum type, ScmObj fn); GLboolean glgdGraphFlagsSet(glgdGraph *graph, GLuint flagMask, glgdFlagOp op); GLboolean glgdGraphDimSet(glgdGraph *graph, glgdVec2 dim); GLboolean glgdGraphDimSetByList(glgdGraph *graph, GLdouble w, GLdouble h); GLboolean glgdGraphDimGet(glgdGraph *graph, glgdVec2 dim); GLboolean glgdGraphMarginSet(glgdGraph *graph, GLdouble margin); GLdouble glgdGraphMarginGet(glgdGraph *graph); GLboolean glgdGraphLineColorSet(glgdGraph *graph, glgdColor col); GLboolean glgdGraphLineColorSetByList(glgdGraph *graph, GLdouble r, GLdouble g, GLdouble b, GLdouble a); GLboolean glgdGraphLineColorGet(glgdGraph *graph, glgdColor col); GLboolean glgdGraphAttributeClear(glgdGraph *graph); GLboolean glgdGraphAttributeSet(glgdGraph *graph, int attrNdx); GLboolean glgdGraphAttributeToggle(glgdGraph *graph, int attrNdx); GLboolean glgdGraphAttributeReset(glgdGraph *graph, int attrNdx); GLboolean glgdGraphAttributeIsSet(glgdGraph *graph, int attrNdx); /* OBSOLETED - do not use */ GLboolean glgdGraphConnect3(glgdGraph *graph, GtkWidget *toplevel, ScmObj glDrawArea); SCM_DECL_END #endif /* __GLGDGRAPH_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdLink.c000066400000000000000000000243351300401456300176270ustar00rootroot00000000000000/* * gldgLink.c * * OpenGL Graph Display link module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" #include "gauche-glgd.h" /* * Defines */ #define _EIGHTH(x) ((x) * 0.125) #define _QUARTER(x) ((x) * 0.250) #define _HALF(x) ((x) * 0.500) #define _THREEQUARTER(x) ((x) * 0.750) /* * External public functions */ glgdLink *glgdLinkCreate(void) { glgdLink *link; link = (glgdLink *)GLGD_MALLOC(sizeof(glgdLink)); if (link) { glgdLinkInit(link); } return link; } glgdLink *glgdLinkDestroy(glgdLink *link) { if (link != NULL) { GLGD_FREE(link); } return (glgdLink *)NULL; } glgdLink *glgdLinkByNdx(glgdLink *head, int ndx) { int n; glgdLink *link; if (head != NULL) { n = 0; link = head; while (link) { if (n == ndx) { return link; } link = link->next; n++; } } return NULL; } int glgdLinkNdx(glgdLink *head, glgdLink *link) { int n; glgdLink *l; if (head != NULL) { n = 0; l = head; while (l) { if (l == link) { return n; } l = l->next; n++; } } return -1; } GLboolean glgdLinkInit(glgdLink *link) { if (link != NULL) { link->flags = GLGDLINK_FLAG_INITIALIZED; link->src = NULL; link->dst = NULL; link->next = NULL; link->prev = NULL; return GL_TRUE; } return GL_FALSE; } GLboolean glgdLinkDraw(glgdLink *link, glgdVec2 dim, GLenum renderMode) { GLdouble mid; glgdVec2 parentPos; glgdVec2 childPos; glgdNode *node, *child; if (link != NULL) { node = link->src; child = link->dst; if (link->flags & GLGDLINK_FLAG_LOOPBACK) { glPushAttrib(GL_CURRENT_BIT); glColor3d(0.6, 0.0, 0.2); if (node->pos[0] < child->pos[0]) { parentPos[0] = node->pos[0] + dim[0] - GLGD_EIGHTH(dim[0]); parentPos[1] = node->pos[1] + dim[1]; childPos[0] = child->pos[0] + dim[0]; childPos[1] = child->pos[1] + GLGD_HALF(dim[1]); if (renderMode == GL_SELECT) { glPushName(node->id); } glBegin(GL_LINES); glVertex2d(parentPos[0], parentPos[1]); glVertex2d(parentPos[0], childPos[1]); glEnd(); if (renderMode == GL_SELECT) { glPopName(); glPushName(child->id); } glBegin(GL_LINES); glVertex2d(parentPos[0], childPos[1]); glVertex2d(childPos[0], childPos[1]); glEnd(); if (renderMode == GL_SELECT) { glPopName(); } } else { parentPos[0] = node->pos[0] + dim[0]; parentPos[1] = node->pos[1] + GLGD_HALF(dim[1]); childPos[0] = child->pos[0] + dim[0]; childPos[1] = child->pos[1] + GLGD_HALF(dim[1]); if (renderMode == GL_SELECT) { glPushName(node->id); } glBegin(GL_LINE_STRIP); glVertex2d(parentPos[0], parentPos[1]); glVertex2d(parentPos[0] + 8.0, parentPos[1]); glVertex2d(parentPos[0] + 8.0, childPos[1]); glEnd(); if (renderMode == GL_SELECT) { glPopName(); } if (renderMode == GL_SELECT) { glPushName(child->id); } glBegin(GL_LINES); glVertex2d(parentPos[0] + 8.0, childPos[1]); glVertex2d(childPos[0], childPos[1]); glEnd(); if (renderMode == GL_SELECT) { glPopName(); } } glPopAttrib(); } else { parentPos[0] = node->pos[0] + GLGD_EIGHTH(dim[0]); parentPos[1] = node->pos[1]; childPos[0] = child->pos[0]; childPos[1] = child->pos[1] + GLGD_HALF(dim[1]); if (renderMode == GL_SELECT) { glPushName(node->id); } glBegin(GL_LINES); glVertex2d(parentPos[0], parentPos[1]); glVertex2d(parentPos[0], childPos[1]); glEnd(); if (renderMode == GL_SELECT) { glPopName(); glPushName(child->id); } glBegin(GL_LINES); glVertex2d(parentPos[0], childPos[1]); glVertex2d(childPos[0], childPos[1]); glEnd(); if (renderMode == GL_SELECT) { glPopName(); } } return GL_TRUE; } return GL_FALSE; } GLboolean glgdLinkSet(glgdLink *link, glgdNode *src, glgdNode *dst) { if (link != NULL) { link->src = src; link->dst = dst; } return GL_FALSE; } GLboolean glgdLinkAdd(glgdLink *head, glgdLink *link) { glgdLink *l; if (head && link) { l = head; while (l->next) { l = l->next; } l->next = link; link->prev = l; return GL_TRUE; } return GL_FALSE; } GLboolean glgdLinkDel(glgdLink *head, glgdLink *link) { glgdLink *l; if (head && link) { l = head; while (l->next && l->next != link) { l = l->next; } if (l->next == link) { l->next = l->next->next; if (l->next) { l->next->prev = l; } return GL_TRUE; } } return GL_FALSE; } GLboolean glgdLinkDump(glgdLink *head) { int ndx; glgdLink *l; ndx = 0; l = head; while (l) { printf("%03d: %s->%s\n", ndx, l->src->label, l->dst->label); l = l->next; ndx++; } return GL_TRUE; } GLboolean glgdLinkFlagsSet(glgdLink *link, GLuint flagMask, glgdFlagOp op) { if (link && op < GLGD_FLAGOP_COUNT) { if (op == GLGD_FLAGOP_CLEAR) { link->flags &= ~flagMask; } else if (op == GLGD_FLAGOP_SET) { link->flags |= flagMask; } else if (op == GLGD_FLAGOP_TOGGLE) { link->flags ^= flagMask; } return GL_TRUE; } return GL_FALSE; } glgdLinkList *glgdLinkListCreate(void) { glgdLinkList *list; list = (glgdLinkList *)GLGD_MALLOC(sizeof(glgdLinkList)); if (list) { glgdLinkListInit(list); } return list; } glgdLinkList *glgdLinkListDestroy(glgdLinkList *list) { if (list != NULL) { GLGD_FREE(list); } return (glgdLinkList *)NULL; } glgdLinkList *glgdLinkListByNdx(glgdLinkList *head, int ndx) { int n; glgdLinkList *list; if (head != NULL) { n = 0; list = head; while (list) { if (n == ndx) { return list; } list = list->next; n++; } } return NULL; } int glgdLinkListNdx(glgdLinkList *head, glgdLinkList *list) { int n; glgdLinkList *l; if (head != NULL) { n = 0; l = head; while (l) { if (l == list) { return n; } l = l->next; n++; } } return -1; } GLboolean glgdLinkListInit(glgdLinkList *list) { if (list != NULL) { list->flags = GLGDLINKLIST_FLAG_INITIALIZED; list->pos[0] = 0.0; list->pos[1] = 0.0; list->linkHead = NULL; list->next = NULL; list->prev = NULL; return GL_TRUE; } return GL_FALSE; } GLboolean glgdLinkListAdd(glgdLinkList *head, glgdLinkList *list) { glgdLinkList *l; if (head && list) { l = head; while (l->next) { l = l->next; } l->next = list; list->prev = l; return GL_TRUE; } return GL_FALSE; } GLboolean glgdLinkListDel(glgdLinkList *head, glgdLinkList *list) { glgdLinkList *l; if (head && list) { l = head; while (l->next && l->next != list) { l = l->next; } if (l->next == list) { l->next = l->next->next; if (l->next) { l->next->prev = l; } return GL_TRUE; } } return GL_FALSE; } GLboolean glgdLinkListDump(glgdLinkList *head) { int ndx; glgdLinkList *l; ndx = 0; l = head; while (l) { printf("%03d: [%6.1f,%6.1f]\n", ndx, l->pos[0], l->pos[1]); printf("--------------------\n"); glgdLinkDump(l->linkHead); l = l->next; ndx++; } return GL_TRUE; } GLboolean glgdLinkListFlagsSet(glgdLinkList *list, GLuint flagMask, glgdFlagOp op) { if (list && op < GLGD_FLAGOP_COUNT) { if (op == GLGD_FLAGOP_CLEAR) { list->flags &= ~flagMask; } else if (op == GLGD_FLAGOP_SET) { list->flags |= flagMask; } else if (op == GLGD_FLAGOP_TOGGLE) { list->flags ^= flagMask; } return GL_TRUE; } return GL_FALSE; } gauche-gtk-0.6+git20160927/glgd/glgdLink.h000066400000000000000000000043201300401456300176240ustar00rootroot00000000000000/* * gldgLink.h * * OpenGL Graph Display link module header file * * Written by: Shawn Taras */ #ifndef __GLGDLINK_H__ #define __GLGDLINK_H__ SCM_DECL_BEGIN /* * Defines */ #define GLGDLINK_FLAG_INITIALIZED (0x0001) #define GLGDLINK_FLAG_LOOPBACK (0x0002) #define GLGDLINK_FLAG_LONER (0x0004) #define GLGDLINKLIST_FLAG_INITIALIZED (0x0001) #define GLGDLINKLIST_FLAG_VISIBLE (0x0002) /* * Type Definitions */ typedef struct _glgdLink { GLuint flags; glgdNode *src; glgdNode *dst; struct _glgdLink *next; struct _glgdLink *prev; } glgdLink; typedef struct _glgdLinkList { GLuint flags; glgdVec2 pos; glgdLink *linkHead; struct _glgdLinkList *next; struct _glgdLinkList *prev; } glgdLinkList; /* * API */ glgdLink *glgdLinkCreate(void); glgdLink *glgdLinkDestroy(glgdLink *link); glgdLink *glgdLinkByNdx(glgdLink *head, int ndx); int glgdLinkNdx(glgdLink *head, glgdLink *link); GLboolean glgdLinkInit(glgdLink *link); GLboolean glgdLinkDraw(glgdLink *link, glgdVec2 dim, GLenum renderMode); GLboolean glgdLinkSet(glgdLink *link, glgdNode *src, glgdNode *dst); GLboolean glgdLinkAdd(glgdLink *head, glgdLink *link); GLboolean glgdLinkDel(glgdLink *head, glgdLink *link); GLboolean glgdLinkDump(glgdLink *head); GLboolean glgdLinkFlagsSet(glgdLink *link, GLuint flagMask, glgdFlagOp op); /* * API */ glgdLinkList *glgdLinkListCreate(void); glgdLinkList *glgdLinkListDestroy(glgdLinkList *list); glgdLinkList *glgdLinkListByNdx(glgdLinkList *head, int ndx); int glgdLinkListNdx(glgdLinkList *head, glgdLinkList *list); GLboolean glgdLinkListInit(glgdLinkList *list); GLboolean glgdLinkListAdd(glgdLinkList *head, glgdLinkList *list); GLboolean glgdLinkListDel(glgdLinkList *head, glgdLinkList *list); GLboolean glgdLinkListDump(glgdLinkList *head); GLboolean glgdLinkListFlagsSet(glgdLinkList *list, GLuint flagMask, glgdFlagOp op); SCM_DECL_END #endif /* __GLGDLINK_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdMatrix.c000066400000000000000000000114371300401456300201750ustar00rootroot00000000000000/* * gldgMatrix.c * * OpenGL Graph Display matrix utility module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" /* * Defines */ #define _SQR(x) ((x) * (x)) /* * Static local (to this module) variables */ static char s_mtxFmt[32] = "|%7.4f %7.4f %7.4f %12.4f|\n"; /* * External public functions */ GLboolean glgdMatrixIdentity(glgdMatrix mtx) { if (mtx != NULL) { mtx[ 0] = 1.0; mtx[ 1] = 0.0; mtx[ 2] = 0.0; mtx[ 3] = 0.0; mtx[ 4] = 0.0; mtx[ 5] = 1.0; mtx[ 6] = 0.0; mtx[ 7] = 0.0; mtx[ 8] = 0.0; mtx[ 9] = 0.0; mtx[10] = 1.0; mtx[11] = 0.0; mtx[12] = 0.0; mtx[13] = 0.0; mtx[14] = 0.0; mtx[15] = 1.0; return GL_TRUE; } return GL_FALSE; } GLboolean glgdMatrixDump(glgdMatrix mtx, int indent) { int i; int ndx; ndx = 0; for (i=0; i<4; i++) { printf(s_mtxFmt, mtx[ndx], mtx[ndx+1], mtx[ndx+2], mtx[ndx+3]); ndx += 4; } } GLboolean glgdMatrixSetByQuat(glgdMatrix mtx, glgdQuat q) { GLdouble s; GLdouble xs; GLdouble ys; GLdouble zs; GLdouble wx; GLdouble wy; GLdouble wz; GLdouble xx; GLdouble xy; GLdouble xz; GLdouble yy; GLdouble yz; GLdouble zz; if (mtx && q) { s = 2.0 / (_SQR(q[0]) + _SQR(q[1]) + _SQR(q[2]) + _SQR(q[3])); xs = q[0] * s; ys = q[1] * s; zs = q[2] * s; wx = q[3] * xs; wy = q[3] * ys; wz = q[3] * zs; xx = q[0] * xs; xy = q[0] * ys; xz = q[0] * zs; yy = q[1] * ys; yz = q[1] * zs; zz = q[2] * zs; mtx[ 0] = 1.0 - (yy + zz); mtx[ 4] = xy - wz; mtx[ 8] = xz + wy; mtx[12] = 0.0; mtx[ 1] = xy + wz; mtx[ 5] = 1.0 - (xx + zz); mtx[ 9] = yz - wx; mtx[13] = 0.0; mtx[ 2] = xz - wy; mtx[ 6] = yz + wx; mtx[10] = 1.0 - (xx + yy); mtx[14] = 0.0; mtx[ 3] = 0.0; mtx[ 7] = 0.0; mtx[11] = 0.0; mtx[15] = 1.0; return GL_TRUE; } return GL_FALSE; } GLboolean glgdMatrixPerspective ( glgdMatrix mtx, GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) { GLdouble xmin, xmax; GLdouble ymin, ymax; if (mtx != NULL) { ymax = zNear * tan(fovy * M_PI / 360.0f); ymin = -ymax; xmin = ymin * aspect; xmax = ymax * aspect; glgdMatrixFrustum(mtx, xmin, xmax, ymin, ymax, zNear, zFar); return GL_TRUE; } return GL_FALSE; } GLboolean glgdMatrixFrustum ( glgdMatrix mtx, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar ) { GLdouble rlInv; GLdouble tbInv; GLdouble fnInv; GLdouble a, b, c, d; GLdouble x, y; if (mtx != NULL) { rlInv = 1.0 / (right - left); tbInv = 1.0 / (top - bottom); fnInv = 1.0 / (zFar - zNear); x = (2.0 * zNear) * rlInv; y = (2.0 * zNear) * tbInv; a = (right + left) * rlInv; b = (top + bottom) * tbInv; c = -(zFar + zNear) * fnInv; d = -(2.0 * zFar * zNear) * fnInv; mtx[ 0] = x; mtx[ 1] = 0.0; mtx[ 2] = 0.0; mtx[ 3] = 0.0; mtx[ 4] = 0.0; mtx[ 5] = y; mtx[ 6] = 0.0; mtx[ 7] = 0.0; mtx[ 8] = a; mtx[ 9] = b; mtx[10] = c; mtx[11] = -1.0; mtx[12] = 0.0; mtx[13] = 0.0; mtx[14] = d; mtx[15] = 0.0; return GL_TRUE; } return GL_FALSE; } GLboolean glgdMatrixOrtho ( glgdMatrix mtx, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar ) { GLdouble x, y, z; GLdouble tx, ty, tz; glgdMatrix m; if (mtx != NULL) { x = +2.0 / (right - left); y = +2.0 / (top - bottom); z = -2.0 / (zFar - zNear); tx = -(right + left) / (right - left); ty = -(top + bottom) / (top - bottom); tz = -(zFar + zNear) / (zFar - zNear); mtx[ 0] = x; mtx[ 1] = 0.0; mtx[ 2] = 0.0; mtx[ 3] = 0.0; mtx[ 4] = 0.0; mtx[ 5] = y; mtx[ 6] = 0.0; mtx[ 7] = 0.0; mtx[ 8] = 0.0; mtx[ 9] = 0.0; mtx[10] = z; mtx[11] = 0.0; mtx[12] = tx; mtx[13] = ty; mtx[14] = tz; mtx[15] = 1.0; return GL_TRUE; } return GL_FALSE; } gauche-gtk-0.6+git20160927/glgd/glgdMatrix.h000066400000000000000000000021331300401456300201730ustar00rootroot00000000000000/* * gldgMatrix.h * * OpenGL Graph Display matrix utility module header file * * Written by: Shawn Taras */ #ifndef __GLGDMATRIX_H__ #define __GLGDMATRIX_H__ SCM_DECL_BEGIN /* * Type Definitions */ typedef GLdouble glgdMatrix[16]; /* * Module API */ GLboolean glgdMatrixIdentity(glgdMatrix mtx); GLboolean glgdMatrixDump(glgdMatrix mtx, int indent); GLboolean glgdMatrixSetByQuat(glgdMatrix mtx, glgdQuat q); GLboolean glgdMatrixPerspective(glgdMatrix mtx, GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar); GLboolean glgdMatrixFrustum(glgdMatrix mtx, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar); GLboolean glgdMatrixOrtho(glgdMatrix mtx, GLdouble left, GLdouble right, GLdouble bottom, GLdouble top, GLdouble zNear, GLdouble zFar); SCM_DECL_END #endif /* __GLGDMATRIX_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdNode.c000066400000000000000000000207131300401456300176130ustar00rootroot00000000000000/* * gldgNode.c * * OpenGL Graph Display node module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" #include "gauche-glgd.h" /* * Defines */ #define _BW (1.0) /* Border width for node box*/ /* * Static local (to this module) variables */ static glgdColor s_nodeColorDefault = {0.45, 0.45, 0.45, 1.00}; /* * Static local (to this module) functions */ static GLdouble glgdNodeTotal(glgdNode *node) { GLdouble total; glgdNode *n; total = 0.0; n = node; while (n) { total += 1.0; n = n->next; } return total; } static GLboolean glgdNodeDrawBox(glgdNode *node, glgdVec2 dim, GLenum renderMode) { int slen; glgdVec2 tpos; glgdVec4 col; glgdStroke *stroke; if (renderMode == GL_SELECT) { glPushName(node->id); } col[0] = node->col[0]; col[1] = node->col[1]; col[2] = node->col[2]; col[3] = node->col[3]; if (node->flags & GLGDNODE_FLAG_HILITE) { col[0] *= GLGDDRAW_LIGHTEN; col[1] *= GLGDDRAW_LIGHTEN; col[2] *= GLGDDRAW_LIGHTEN; } if (node->flags & GLGDNODE_FLAG_DIM) { col[0] *= GLGDDRAW_DARKEN; col[1] *= GLGDDRAW_DARKEN; col[2] *= GLGDDRAW_DARKEN; } if (node->flags & GLGDNODE_FLAG_SELECTED) { col[0] = 1.0; col[1] = 1.0; col[2] = 0.0; } glgdDrawBox(GLGDDRAW_BOXTYPE_UP, node->pos, dim, col, _BW); if (renderMode == GL_SELECT) { glPopName(); } #ifndef HAVE_GLGD_PANGO /* Draw node label */ stroke = glgdStrokeGetCurrent(); if (stroke) { slen = strlen(node->label) * stroke->pointSize[0]; tpos[0] = node->pos[0] + GLGD_HALF(dim[0] - slen); tpos[1] = node->pos[1] + GLGD_THREEQUARTER(dim[1]); glgdStrokePosSet(stroke, tpos); glgdStrokePrint(stroke, node->label); } #endif /* HAVE_GLGD_PANGO */ return GL_FALSE; } static void glgdNodeExtentsUpdate(glgdVec2 pos, glgdVec2 dim, glgdVec4 extents) { if (pos[0] < extents[0]) extents[0] = pos[0]; if (pos[1] < extents[1]) extents[1] = pos[1]; if (pos[0] + dim[0] > extents[2]) { extents[2] = pos[0] + dim[0]; } if (pos[1] + dim[1] > extents[3]) { extents[3] = pos[1] + dim[1]; } } /* * External public functions */ glgdNode *glgdNodeCreate(void) { glgdNode *node; node = (glgdNode *)GLGD_MALLOC(sizeof(glgdNode)); if (node) { glgdNodeInit(node); } return node; } glgdNode *glgdNodeDestroy(glgdNode *node) { glgdNode *next; if (node->next) { node->next = glgdNodeDestroy(node->next); } GLGD_FREE(node); return (glgdNode *)NULL; } glgdNode *glgdNodeByID(glgdNode *nodeList, int id) { glgdNode *n; if (nodeList) { n = nodeList; while (n) { if (n->id == id) { return n; } n = n->next; } } return NULL; } GLboolean glgdNodeInit(glgdNode *node) { if (node != NULL) { node->flags = GLGDNODE_FLAG_INITIALIZED; node->label[0] = '\0'; node->id = -1; node->pos[0] = 0.0; node->pos[1] = 0.0; node->col[0] = s_nodeColorDefault[0]; node->col[1] = s_nodeColorDefault[1]; node->col[2] = s_nodeColorDefault[2]; node->col[3] = s_nodeColorDefault[3]; glgdNodeAttributeClear(node); glgdNodeAttributeSet(node, GLGD_ATTR_FORCEVISIBLE); node->data = NULL; node->next = NULL; node->prev = NULL; return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodeDraw ( glgdNode *node, glgdVec2 dim, ScmObj prFn, GLenum renderMode ) { if (node != NULL) { if (prFn != NULL) { Scm_ApplyRec(prFn, SCM_LIST1(SCM_OBJ(SCM_MAKE_GLGD_NODE(node)))); } glgdNodeDrawBox(node, dim, renderMode); return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodeLabelSet(glgdNode *node, const char *label) { if (node != NULL) { strncpy(node->label, label, GLGDNODE_LABEL_MAX-1); node->label[GLGDNODE_LABEL_MAX-1] = '\0'; return GL_TRUE; } return GL_FALSE; } ScmObj glgdNodeLabelGet(glgdNode *node) { if (node != NULL) { return SCM_MAKE_STR_COPYING(node->label); } return SCM_FALSE; } GLboolean glgdNodeDataSet(glgdNode *node, ScmObj data) { if (node != NULL) { node->data = data; } return GL_FALSE; } ScmObj glgdNodeDataGet(glgdNode *node) { if (node != NULL) { return node->data; } return SCM_FALSE; } GLboolean glgdNodeIDSet(glgdNode *node, int id) { if (node != NULL) { node->id = id; return GL_TRUE; } return GL_FALSE; } int glgdNodeIDGet(glgdNode *node) { if (node) { return node->id; } return -1; } GLboolean glgdNodeInfoSet(glgdNode *node, const char *label, int id) { if (glgdNodeLabelSet(node, label) == GL_TRUE) { return glgdNodeIDSet(node, id); } return GL_FALSE; } GLboolean glgdNodeTranslate(glgdNode *node, glgdVec2 xlat, glgdVec2 dim, glgdVec4 extents) { glgdNode *n; if (node && xlat) { n = node; while (n) { n->pos[0] += xlat[0]; n->pos[1] += xlat[1]; glgdNodeExtentsUpdate(n->pos, dim, extents); n = n->next; } return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodeFlagsSet(glgdNode *node, GLuint flagMask, glgdFlagOp op) { if (node && op < GLGD_FLAGOP_COUNT) { if (op == GLGD_FLAGOP_CLEAR) { node->flags &= ~flagMask; } else if (op == GLGD_FLAGOP_SET) { node->flags |= flagMask; } else if (op == GLGD_FLAGOP_TOGGLE) { node->flags ^= flagMask; } return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodeIsSelected(glgdNode *node) { if (node != NULL) { if (node->flags & GLGDNODE_FLAG_SELECTED) { return GL_TRUE; } } return GL_FALSE; } GLboolean glgdNodeIsTouched(glgdNode *node) { if (node != NULL) { if (node->flags & GLGDNODE_FLAG_TOUCHED) { return GL_TRUE; } } return GL_FALSE; } void glgdNodeColorDefault(GLdouble r, GLdouble g, GLdouble b, GLdouble a) { s_nodeColorDefault[0] = r; s_nodeColorDefault[1] = g; s_nodeColorDefault[2] = b; s_nodeColorDefault[3] = a; } GLboolean glgdNodeColorSetByList(glgdNode *node, GLdouble r, GLdouble g, GLdouble b, GLdouble a) { if (node) { node->col[0] = r; node->col[1] = g; node->col[2] = b; node->col[3] = a; return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodePosSet(glgdNode *node, glgdVec2 pos, glgdVec2 dim, glgdVec4 extents) { if (node != NULL) { node->pos[0] = pos[0]; node->pos[1] = pos[1]; glgdNodeExtentsUpdate(node->pos, dim, extents); return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodePosSetByList(glgdNode *node, GLdouble x, GLdouble y, glgdVec2 dim, glgdVec4 extents) { if (node != NULL) { node->pos[0] = x; node->pos[1] = y; glgdNodeExtentsUpdate(node->pos, dim, extents); return GL_TRUE; } return GL_FALSE; } GLboolean glgdNodeAttributeClear(glgdNode *node) { int i; if (node != NULL) { return glgdBitfieldClear(&node->attributes); } return GL_FALSE; } GLboolean glgdNodeAttributeSet(glgdNode *node, int attrNdx) { if (node) { return glgdBitfieldSet(&node->attributes, attrNdx); } return GL_FALSE; } GLboolean glgdNodeAttributeReset(glgdNode *node, int attrNdx) { if (node) { return glgdBitfieldReset(&node->attributes, attrNdx); } return GL_FALSE; } GLboolean glgdNodeAttributeIsSet(glgdNode *node, int attrNdx) { if (node) { return glgdBitfieldIsSet(&node->attributes, attrNdx); } return GL_FALSE; } gauche-gtk-0.6+git20160927/glgd/glgdNode.h000066400000000000000000000050441300401456300176200ustar00rootroot00000000000000/* * gldgNode.h * * OpenGL Graph Display node module header file * * Written by: Shawn Taras */ #ifndef __GLGDNODE_H__ #define __GLGDNODE_H__ SCM_DECL_BEGIN /* * Defines */ #define GLGDNODE_FLAG_INITIALIZED (0x0001) #define GLGDNODE_FLAG_TOUCHED (0x0002) #define GLGDNODE_FLAG_HILITE (0x0004) #define GLGDNODE_FLAG_DIM (0x0008) #define GLGDNODE_FLAG_SELECTED (0x0010) #define GLGDNODE_LABEL_MAX (64) /* * Type Definitions */ typedef struct _glgdNode { GLuint flags; char label[GLGDNODE_LABEL_MAX]; int id; glgdVec2 pos; glgdColor col; glgdBitfield attributes; ScmObj data; struct _glgdNode *next; struct _glgdNode *prev; } glgdNode; /* * Module API */ glgdNode *glgdNodeCreate(void); glgdNode *glgdNodeDestroy(glgdNode *node); glgdNode *glgdNodeByID(glgdNode *nodeList, int id); GLboolean glgdNodeInit(glgdNode *node); GLboolean glgdNodeDraw(glgdNode *node, glgdVec2 dim, ScmObj prFn, GLenum renderMode); GLboolean glgdNodeLabelSet(glgdNode *node, const char *label); ScmObj glgdNodeLabelGet(glgdNode *node); GLboolean glgdNodeDataSet(glgdNode *node, ScmObj data); ScmObj glgdNodeDataGet(glgdNode *node); GLboolean glgdNodeIDSet(glgdNode *node, int id); int glgdNodeIDGet(glgdNode *node); GLboolean glgdNodeInfoSet(glgdNode *node, const char *label, int id); GLboolean glgdNodeTranslate(glgdNode *nodeList, glgdVec2 xlat, glgdVec2 dim, glgdVec4 extents); GLboolean glgdNodeFlagsSet(glgdNode *node, GLuint flagMask, glgdFlagOp op); GLboolean glgdNodeIsSelected(glgdNode *node); GLboolean glgdNodeIsTouched(glgdNode *node); void glgdNodeColorDefault(GLdouble r, GLdouble g, GLdouble b, GLdouble a); GLboolean glgdNodeColorSetByList(glgdNode *node, GLdouble r, GLdouble g, GLdouble b, GLdouble a); GLboolean glgdNodePosSet(glgdNode *node, glgdVec2 pos, glgdVec2 dim, glgdVec4 extents); GLboolean glgdNodePosSetByList(glgdNode *node, GLdouble x, GLdouble y, glgdVec2 dim, glgdVec4 extents); GLboolean glgdNodeAttributeClear(glgdNode *node); GLboolean glgdNodeAttributeSet(glgdNode *node, int attrNdx); GLboolean glgdNodeAttributeReset(glgdNode *node, int attrNdx); GLboolean glgdNodeAttributeIsSet(glgdNode *node, int attrNdx); SCM_DECL_END #endif /* __GLGDNODE_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdQuat.c000066400000000000000000000176451300401456300176520ustar00rootroot00000000000000/* * gldgQuat.c * * OpenGL Graph Display quaternion utility module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" /* * Defines */ #define _SQR(x) ((x) * (x)) #define _EPSILON (0.0005) #define _PI (M_PI) /* * External public functions */ GLboolean glgdQuatIdentity(glgdQuat q) { if (q != NULL) { q[0] = 0.0; q[1] = 0.0; q[2] = 0.0; q[3] = 1.0; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSet(glgdQuat dst, glgdQuat src) { if (src && dst) { dst[0] = src[0]; dst[1] = src[1]; dst[2] = src[2]; dst[3] = src[3]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSetByList(glgdQuat dst, GLdouble x, GLdouble y, GLdouble z, GLdouble w) { if (dst != NULL) { dst[0] = x; dst[1] = y; dst[2] = z; dst[3] = w; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSetByEuler(glgdQuat q, GLdouble xRad, GLdouble yRad, GLdouble zRad) { GLdouble sinX, sinY, sinZ; GLdouble cosX, cosY, cosZ; GLdouble halfX, halfY, halfZ; if (q != NULL) { halfX = xRad * 0.5; halfY = yRad * 0.5; halfZ = zRad * 0.5; cosX = cos(halfX); cosY = cos(halfY); cosZ = cos(halfZ); sinX = sin(halfX); sinY = sin(halfY); sinZ = sin(halfZ); q[0] = sinX * cosY * cosZ - cosX * sinY * sinZ; q[1] = cosX * sinY * cosZ + sinX * cosY * sinZ; q[2] = cosX * cosY * sinZ - sinX * sinY * cosZ; q[3] = cosX * cosY * cosZ + sinX * sinY * sinZ; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSetByXRotation(glgdQuat q, GLdouble xRad) { GLdouble sinX; GLdouble cosX; GLdouble halfX; if (q != NULL) { halfX = xRad * 0.5; cosX = cos(halfX); sinX = sin(halfX); q[0] = sinX; q[1] = 0.0; q[2] = 0.0; q[3] = cosX; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSetByYRotation(glgdQuat q, GLdouble yRad) { GLdouble sinY; GLdouble cosY; GLdouble halfY; if (q != NULL) { halfY = yRad * 0.5; cosY = cos(halfY); sinY = sin(halfY); q[0] = 0.0; q[1] = sinY; q[2] = 0.0; q[3] = cosY; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSetByZRotation(glgdQuat q, GLdouble zRad) { GLdouble sinZ; GLdouble cosZ; GLdouble halfZ; if (q != NULL) { halfZ = zRad * 0.5; cosZ = cos(halfZ); sinZ = sin(halfZ); q[0] = 0.0; q[1] = 0.0; q[2] = sinZ; q[3] = cosZ; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSetByNormalizedAxis(glgdQuat q, GLdouble *axis, GLdouble thetaRad) { GLdouble sinTheta; GLdouble cosTheta; GLdouble halfTheta; if (q && axis) { halfTheta = thetaRad * 0.5; cosTheta = cos(halfTheta); sinTheta = sin(halfTheta); q[0] = sinTheta * axis[0]; q[1] = sinTheta * axis[1]; q[2] = sinTheta * axis[2]; q[3] = cosTheta; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatAdd(glgdQuat dst, glgdQuat qa, glgdQuat qb) { if (dst && qa && qb) { dst[0] = qa[0] + qb[0]; dst[1] = qa[1] + qb[1]; dst[2] = qa[2] + qb[2]; dst[3] = qa[3] + qb[3]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatSub(glgdQuat dst, glgdQuat qa, glgdQuat qb) { if (dst && qa && qb) { dst[0] = qa[0] - qb[0]; dst[1] = qa[1] - qb[1]; dst[2] = qa[2] - qb[2]; dst[3] = qa[3] - qb[3]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatMult(glgdQuat dst, glgdQuat qa, glgdQuat qb) { if (dst && qa && qb) { dst[0] = qa[3]*qb[0] + qa[0]*qb[3] + qa[1]*qb[2] - qa[2]*qb[1]; dst[1] = qa[3]*qb[1] + qa[1]*qb[3] + qa[2]*qb[0] - qa[0]*qb[2]; dst[2] = qa[3]*qb[2] + qa[2]*qb[3] + qa[0]*qb[1] - qa[1]*qb[0]; dst[3] = qa[3]*qb[3] - qa[0]*qb[0] - qa[1]*qb[1] - qa[2]*qb[2]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatLog(glgdQuat dst, glgdQuat src) { GLdouble scale, theta; if (dst && src) { scale = sqrt(_SQR(src[0]) + _SQR(src[1]) + _SQR(src[2])); if (scale > 0.0) { theta = atan2(scale, src[3]); scale = theta / scale; } dst[0] = src[0] * scale; dst[1] = src[1] * scale; dst[2] = src[2] * scale; dst[3] = 0.0f; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatExp(glgdQuat dst, glgdQuat src) { GLdouble scale, theta; if (dst && src) { theta = sqrt(_SQR(src[0]) + _SQR(src[1]) + _SQR(src[2])); scale = (theta > _EPSILON) ? (sin(theta) / theta) : 1.0; dst[0] = src[0] * scale; dst[1] = src[1] * scale; dst[2] = src[2] * scale; dst[3] = cos(theta); return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatConjugate(glgdQuat dst, glgdQuat src) { if (dst && src) { dst[0] = -src[0]; dst[1] = -src[1]; dst[2] = -src[2]; dst[3] = src[3]; return GL_TRUE; } return GL_FALSE; } GLboolean glgdQuatInverse(glgdQuat dst, glgdQuat src) { GLdouble len2; GLdouble factor; if (dst && src) { len2 = _SQR(src[0]) + _SQR(src[1]) + _SQR(src[2]) + _SQR(src[3]); if (len2 > 0.0) { factor = 1.0f / sqrt(len2); dst[0] = -src[0] * factor; dst[1] = -src[1] * factor; dst[2] = -src[2] * factor; dst[3] = -src[3] * factor; return GL_TRUE; } else { glgdQuatIdentity(dst); } } return GL_FALSE; } GLboolean glgdQuatSlerp(glgdQuat dst, glgdQuat qa, glgdQuat qb, GLdouble t) { GLdouble omega; GLdouble sinOmega, cosOmega; GLdouble startScale, endScale; if (dst && qa && qb) { cosOmega = glgdQuatDot(qa, qb); if ((1.0 + cosOmega) > _EPSILON) { if ((1.0 - cosOmega) > _EPSILON) { omega = acos(cosOmega); sinOmega = sin(omega); startScale = sin((1.0 - t) * omega) / sinOmega; endScale = sin(t * omega) / sinOmega; } else { startScale = 1.0 - t; endScale = t; } dst[0] = qa[0] * startScale + qb[0] * endScale; dst[1] = qa[1] * startScale + qb[1] * endScale; dst[2] = qa[2] * startScale + qb[2] * endScale; dst[3] = qa[3] * startScale + qb[3] * endScale; } else { dst[0] = -qa[1]; dst[1] = qa[0]; dst[2] = -qa[3]; dst[3] = qa[2]; startScale = sin((0.5f - t) * _PI); endScale = sin(t * _PI); dst[0] = qa[0] * startScale + qb[0] * endScale; dst[1] = qa[1] * startScale + qb[1] * endScale; dst[2] = qa[2] * startScale + qb[2] * endScale; dst[3] = qa[3] * startScale + qb[3] * endScale; } return GL_TRUE; } return GL_FALSE; } GLdouble glgdQuatDot(glgdQuat qa, glgdQuat qb) { if (qa && qb) { return ((qa[0]*qb[0]) + (qa[1]*qb[1]) + (qa[2]*qb[2]) + (qa[3]*qb[3])); } return 0.0; } gauche-gtk-0.6+git20160927/glgd/glgdQuat.h000066400000000000000000000025511300401456300176450ustar00rootroot00000000000000/* * glgdQuat.h * * OpenGL Graph Display quaternion utility module header file * * Written by: Shawn Taras */ #ifndef __GLGDQUAT_H__ #define __GLGDQUAT_H__ SCM_DECL_BEGIN /* * Type Definitions */ typedef GLdouble glgdQuat[4]; /* * Module API */ GLboolean glgdQuatIdentity(glgdQuat q); GLboolean glgdQuatSet(glgdQuat dst, glgdQuat src); GLboolean glgdQuatSetByList(glgdQuat dst, GLdouble x, GLdouble y, GLdouble z, GLdouble w); GLboolean glgdQuatSetByEuler(glgdQuat q, GLdouble xRad, GLdouble yRad, GLdouble zRad); GLboolean glgdQuatSetByXRotation(glgdQuat q, GLdouble xRad); GLboolean glgdQuatSetByYRotation(glgdQuat q, GLdouble yRad); GLboolean glgdQuatSetByZRotation(glgdQuat q, GLdouble zRad); GLboolean glgdQuatAdd(glgdQuat dst, glgdQuat qa, glgdQuat qb); GLboolean glgdQuatSub(glgdQuat dst, glgdQuat qa, glgdQuat qb); GLboolean glgdQuatMult(glgdQuat dst, glgdQuat qa, glgdQuat qb); GLboolean glgdQuatLog(glgdQuat dst, glgdQuat src); GLboolean glgdQuatExp(glgdQuat dst, glgdQuat src); GLboolean glgdQuatConjugate(glgdQuat dst, glgdQuat src); GLboolean glgdQuatInverse(glgdQuat dst, glgdQuat src); GLboolean glgdQuatSlerp(glgdQuat dst, glgdQuat qa, glgdQuat qb, GLdouble t); GLdouble glgdQuatDot(glgdQuat qa, glgdQuat qb); SCM_DECL_END #endif /* __GLGDQUAT_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdStroke.c000066400000000000000000000617031300401456300202010ustar00rootroot00000000000000/* * gldgStroke.c * * OpenGL Graph Display stroke font module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" /* * Static local (to this module) variables */ static glgdStroke *s_currentStroke = NULL; static GLint s_blendFunc[2] = {GL_ONE, GL_ZERO}; /* ASCII Character tristrips drawn into a 16x16 pixel area * --> NOTE! origin of 16x16 area is lower-left corner */ static const unsigned char s_g20[] = { 0xff, 0xff }; static const unsigned char s_g21[] = { 0x60, 0x80, 0x62, 0x82, 0xff, 0x64, 0x84, 0x6e, 0x8e, 0xff, 0xff }; static const unsigned char s_g22[] = { 0x6a, 0x6e, 0x4c, 0x4e, 0xff, 0x8a, 0xac, 0x8e, 0xae, 0xff, 0xff }; static const unsigned char s_g23[] = { 0x42, 0x62, 0x44, 0x64, 0x46, 0x66, 0x48, 0x68, 0x4a, 0x6a, 0x4c, 0x6c, 0xff, 0x82, 0xa2, 0x84, 0xa4, 0x86, 0xa6, 0x88, 0xa8, 0x8a, 0xaa, 0x8c, 0xac, 0xff, 0x24, 0x44, 0x26, 0x46, 0xff, 0x64, 0x84, 0x66, 0x86, 0xff, 0xa4, 0xc4, 0xa6, 0xc6, 0xff, 0x28, 0x48, 0x2a, 0x4a, 0xff, 0x68, 0x88, 0x6a, 0x8a, 0xff, 0xa8, 0xc8, 0xaa, 0xca, 0xff, 0xff }; static const unsigned char s_g24[] = { 0x46, 0x48, 0x26, 0x38, 0x08, 0x29, 0x0a, 0x3a, 0x2c, 0x4a, 0x4c, 0xff, 0xa8, 0xa6, 0xc8, 0xb6, 0xe6, 0xc5, 0xe4, 0xb4, 0xc2, 0xa4, 0xa2, 0xff, 0x25, 0x04, 0x34, 0x22, 0x44, 0x42, 0xff, 0xc9, 0xea, 0xba, 0xcc, 0xaa, 0xac, 0xff, 0x40, 0x60, 0x42, 0x62, 0x44, 0x64, 0x46, 0x66, 0x48, 0x68, 0x4a, 0x6a, 0x4c, 0x6c, 0x4e, 0x6e, 0xff, 0x80, 0xa0, 0x82, 0xa2, 0x84, 0xa4, 0x86, 0xa6, 0x88, 0xa8, 0x8a, 0xaa, 0x8c, 0xac, 0x8e, 0xae, 0xff, 0x62, 0x82, 0x64, 0x84, 0xff, 0x66, 0x86, 0x68, 0x88, 0xff, 0x6a, 0x8a, 0x6c, 0x8c, 0xff, 0xff }; static const unsigned char s_g25[] = { 0x00, 0x20, 0x02, 0xec, 0xce, 0xee, 0xff, 0xa0, 0xb2, 0x82, 0xa3, 0x84, 0xb4, 0xa6, 0xc6, 0xff, 0xc6, 0xb4, 0xe4, 0xc3, 0xe2, 0xb2, 0xc0, 0xa0, 0xff, 0x28, 0x3a, 0x0a, 0x2b, 0x0c, 0x3c, 0x2e, 0x4e, 0xff, 0x4e, 0x3c, 0x6c, 0x4b, 0x6a, 0x3a, 0x48, 0x28, 0xff, 0xff }; static const unsigned char s_g26[] = { 0xa0, 0xe0, 0x91, 0xb3, 0x73, 0x95, 0x55, 0x77, 0x37, 0x59, 0x28, 0x4a, 0x2c, 0x4b, 0x4e, 0x5c, 0x6e, 0x6b, 0x8c, 0x6a, 0x88, 0x59, 0x77, 0xff, 0x91, 0x73, 0x80, 0x62, 0x20, 0x42, 0x02, 0x33, 0x04, 0x55, 0x37, 0xff, 0x95, 0xb3, 0xa6, 0xc4, 0xff, 0xff }; static const unsigned char s_g27[] = { 0x6a, 0x8c, 0x6e, 0x8e, 0xff, 0xff }; static const unsigned char s_g28[] = { 0x80, 0xa0, 0x62, 0x82, 0x6c, 0x8c, 0x8e, 0xae, 0xff, 0xff }; static const unsigned char s_g29[] = { 0x40, 0x60, 0x62, 0x82, 0x6c, 0x8c, 0x4e, 0x6e, 0xff, 0xff }; static const unsigned char s_g2A[] = { 0x77, 0xa8, 0x8a, 0xb9, 0x9b, 0xff, 0x77, 0x8a, 0x6a, 0x8c, 0x6c, 0xff, 0x77, 0x6a, 0x48, 0x5b, 0x39, 0xff, 0x77, 0x48, 0x46, 0x28, 0x26, 0xff, 0x77, 0x46, 0x64, 0x35, 0x53, 0xff, 0x77, 0x64, 0x84, 0x62, 0x82, 0xff, 0x77, 0x84, 0xa6, 0x93, 0xb5, 0xff, 0x77, 0xa6, 0xa8, 0xc6, 0xc8, 0xff, 0xff }; static const unsigned char s_g2B[] = { 0x62, 0x82, 0x66, 0x86, 0x88, 0xc6, 0xc8, 0xff, 0x8c, 0x6c, 0x88, 0x68, 0x66, 0x28, 0x26, 0xff, 0xff }; static const unsigned char s_g2C[] = { 0x84, 0x64, 0x82, 0x60, 0xff, 0xff }; static const unsigned char s_g2D[] = { 0x28, 0x26, 0xc8, 0xc6, 0xff, 0xff }; static const unsigned char s_g2E[] = { 0x60, 0x80, 0x62, 0x82, 0xff, 0xff }; static const unsigned char s_g2F[] = { 0x00, 0x20, 0x02, 0xec, 0xce, 0xee, 0xff, 0xff }; static const unsigned char s_g30[] = { 0x24, 0x42, 0xac, 0xca, 0xff, 0xb2, 0xc0, 0xc3, 0xe2, 0xca, 0xec, 0xac, 0xce, 0x3c, 0x2e, 0x2b, 0x0c, 0x24, 0x02, 0x42, 0x20, 0xb2, 0xc0, 0xff, 0xff }; static const unsigned char s_g31[] = { 0x80, 0xff, 0x4c, 0x4a, 0x6e, 0x6a, 0x8e, 0x60, 0x80, 0xff, 0xff }; static const unsigned char s_g32[] = { 0x0c, 0x2b, 0x2e, 0x3c, 0xce, 0xbc, 0xec, 0xcb, 0xe8, 0xc9, 0xc6, 0xb8, 0x36, 0x28, 0x25, 0x06, 0x22, 0x00, 0xe2, 0xe0, 0xff, 0xff }; static const unsigned char s_g33[] = { 0x0c, 0x2b, 0x2e, 0x3c, 0xce, 0xbc, 0xec, 0xcb, 0xe8, 0xc9, 0xd7, 0xb8, 0xb6, 0x68, 0x66, 0xff, 0xd7, 0xb6, 0xe6, 0xc5, 0xe2, 0xc3, 0xc0, 0xb2, 0x20, 0x32, 0x02, 0x23, 0xff, 0xff }; static const unsigned char s_g34[] = { 0xc6, 0xc8, 0x06, 0x28, 0x0c, 0x2c, 0xff, 0xc0, 0xe0, 0xc6, 0xe7, 0xc8, 0xee, 0xce, 0xff, 0xff }; static const unsigned char s_g35[] = { 0xec, 0xee, 0x2c, 0x0e, 0x29, 0x08, 0x38, 0x26, 0xc8, 0xb6, 0xe6, 0xc5, 0xe2, 0xc3, 0xc0, 0xb2, 0x20, 0x32, 0x02, 0x23, 0xff, 0xff }; static const unsigned char s_g36[] = { 0xcb, 0xec, 0xbc, 0xce, 0x3c, 0x2e, 0x2b, 0x0c, 0x28, 0x07, 0x26, 0x02, 0x23, 0x20, 0x32, 0xc0, 0xb2, 0xe2, 0xc3, 0xe6, 0xc5, 0xc8, 0xb6, 0x28, 0x26, 0xff, 0xff }; static const unsigned char s_g37[] = { 0x0e, 0x0c, 0xee, 0xbc, 0xec, 0x67, 0x86, 0x60, 0x80, 0xff, 0xff }; static const unsigned char s_g38[] = { 0x36, 0x17, 0x25, 0x06, 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc5, 0xe6, 0xb6, 0xd7, 0xb8, 0xe8, 0xc9, 0xec, 0xcb, 0xce, 0xbc, 0x2e, 0x3c, 0x0c, 0x2b, 0x08, 0x29, 0x17, 0x38, 0x36, 0xb8, 0xb6, 0xff, 0xff }; static const unsigned char s_g39[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc6, 0xe7, 0xc8, 0xec, 0xcb, 0xce, 0xbc, 0x2e, 0x3c, 0x0c, 0x2b, 0x08, 0x29, 0x26, 0x38, 0xc6, 0xc8, 0xff, 0xff }; static const unsigned char s_g3A[] = { 0x60, 0x80, 0x62, 0x82, 0xff, 0x66, 0x86, 0x68, 0x88, 0xff, 0xff }; static const unsigned char s_g3B[] = { 0x84, 0x64, 0x82, 0x60, 0xff, 0x66, 0x86, 0x68, 0x88, 0xff, 0xff }; static const unsigned char s_g3C[] = { 0xbc, 0x8c, 0x67, 0x37, 0xb2, 0x82, 0xff, 0xff }; static const unsigned char s_g3D[] = { 0x24, 0x26, 0xc4, 0xc6, 0xff, 0x28, 0x2a, 0xc8, 0xca, 0xff, 0xff }; static const unsigned char s_g3E[] = { 0x32, 0x62, 0x87, 0xb7, 0x3c, 0x6c, 0xff, 0xff }; static const unsigned char s_g3F[] = { 0x60, 0x80, 0x62, 0x82, 0xff, 0x64, 0x84, 0x65, 0xea, 0xcb, 0xec, 0xbc, 0xce, 0x3c, 0x2e, 0x2b, 0x0c, 0xff, 0xff }; static const unsigned char s_g40[] = { 0xe2, 0xc3, 0xc0, 0xb2, 0x20, 0x32, 0x02, 0x23, 0x0c, 0x2b, 0x2e, 0x3c, 0xce, 0xbc, 0xec, 0xcb, 0xe6, 0xc7, 0xc4, 0xb6, 0xa4, 0xa6, 0x84, 0x86, 0x64, 0x76, 0x46, 0x67, 0x48, 0x78, 0x6a, 0x88, 0xaa, 0x86, 0xa6, 0xff, 0xff }; static const unsigned char s_g41[] = { 0x00, 0x20, 0x08, 0x26, 0x38, 0xc6, 0xb8, 0xff, 0xc0, 0xe0, 0xc6, 0xe8, 0xb8, 0x8e, 0x7c, 0x6e, 0x38, 0x08, 0xff, 0xff }; static const unsigned char s_g42[] = { 0xb8, 0xd7, 0xc9, 0xe8, 0xcb, 0xec, 0xbc, 0xce, 0x2c, 0x0e, 0x28, 0x07, 0x26, 0x00, 0x22, 0xc0, 0xb2, 0xe2, 0xc3, 0xe6, 0xc5, 0xd7, 0xb6, 0xb8, 0x26, 0x28, 0xff, 0xff }; static const unsigned char s_g43[] = { 0xcb, 0xec, 0xbc, 0xce, 0x3c, 0x2e, 0x2b, 0x0c, 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xff, 0xff }; static const unsigned char s_g44[] = { 0x22, 0x00, 0xb2, 0xc0, 0xc3, 0xe2, 0xcb, 0xec, 0xbc, 0xce, 0x2c, 0x0e, 0x22, 0x00, 0xff, 0xff }; static const unsigned char s_g45[] = { 0xe0, 0xe2, 0x00, 0x22, 0x06, 0x26, 0x08, 0x28, 0x0e, 0x2c, 0xee, 0xec, 0xff, 0x28, 0x26, 0x88, 0x86, 0xff, 0xff }; static const unsigned char s_g46[] = { 0x00, 0x20, 0x06, 0x26, 0x08, 0x28, 0x0e, 0x2c, 0xee, 0xec, 0xff, 0x28, 0x26, 0x88, 0x86, 0xff, 0xff }; static const unsigned char s_g47[] = { 0xcb, 0xec, 0xbc, 0xce, 0x3c, 0x2e, 0x2b, 0x0c, 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc6, 0xe8, 0x86, 0x88, 0xff, 0xff }; static const unsigned char s_g48[] = { 0x2e, 0x0e, 0x28, 0x07, 0x26, 0x00, 0x20, 0xff, 0xc0, 0xe0, 0xc6, 0xe7, 0xc8, 0xee, 0xce, 0xff, 0x28, 0x26, 0xc8, 0xc6, 0xff, 0xff }; static const unsigned char s_g49[] = { 0x42, 0x40, 0x62, 0x60, 0x82, 0x80, 0xa2, 0xa0, 0xff, 0x4e, 0x4c, 0x6e, 0x6c, 0x8e, 0x8c, 0xae, 0xac, 0xff, 0x62, 0x82, 0x6c, 0x8c, 0xff, 0xff }; static const unsigned char s_g4A[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xce, 0xee, 0xff, 0xff }; static const unsigned char s_g4B[] = { 0x2e, 0x0e, 0x28, 0x07, 0x26, 0x00, 0x20, 0xff, 0x28, 0x26, 0x68, 0x66, 0x97, 0xc0, 0xe2, 0xe0, 0xff, 0x68, 0x97, 0xce, 0xec, 0xee, 0xff, 0xff }; static const unsigned char s_g4C[] = { 0xe0, 0xe2, 0x00, 0x22, 0x0e, 0x2e, 0xff, 0xff }; static const unsigned char s_g4D[] = { 0x00, 0x20, 0x0e, 0x2b, 0x2e, 0x67, 0x79, 0x87, 0xce, 0xcb, 0xee, 0xc0, 0xe0, 0xff, 0xff }; static const unsigned char s_g4E[] = { 0x00, 0x20, 0x0e, 0x2b, 0x2e, 0xc0, 0xc3, 0xe0, 0xce, 0xee, 0xff, 0xff }; static const unsigned char s_g4F[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xcb, 0xec, 0xbc, 0xce, 0x3c, 0x2e, 0x2b, 0x0c, 0x23, 0x02, 0xff, 0xff }; static const unsigned char s_g50[] = { 0x00, 0x20, 0x06, 0x26, 0x08, 0x28, 0x0c, 0x2c, 0x0e, 0xbc, 0xce, 0xcb, 0xec, 0xc9, 0xe8, 0xb8, 0xc6, 0x28, 0x26, 0xff, 0xff }; static const unsigned char s_g51[] = { 0xc0, 0xe2, 0xc4, 0xec, 0xcb, 0xce, 0xbc, 0x2e, 0x3c, 0x0c, 0x2b, 0x02, 0x23, 0x20, 0x32, 0xc0, 0xa2, 0xc4, 0x84, 0xa6, 0xff, 0xff }; static const unsigned char s_g52[] = { 0xc0, 0xe0, 0xc5, 0xe6, 0xb6, 0xd7, 0xb8, 0xe8, 0xc9, 0xec, 0xcb, 0xce, 0xbc, 0x0e, 0x2c, 0x08, 0x28, 0x06, 0x26, 0x00, 0x20, 0xff, 0x28, 0x26, 0xb8, 0xb6, 0xff, 0xff }; static const unsigned char s_g53[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc5, 0xe6, 0xb6, 0xc8, 0x26, 0x38, 0x08, 0x29, 0x0c, 0x2b, 0x2e, 0x3c, 0xce, 0xbc, 0xec, 0xcb, 0xff, 0xff }; static const unsigned char s_g54[] = { 0x0e, 0x0c, 0x6e, 0x6c, 0x8e, 0x8c, 0xee, 0xec, 0xff, 0x60, 0x80, 0x6c, 0x8c, 0xff, 0xff }; static const unsigned char s_g55[] = { 0x2e, 0x0e, 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xce, 0xee, 0xff, 0xff }; static const unsigned char s_g56[] = { 0x2e, 0x0e, 0x27, 0x06, 0x72, 0x60, 0xff, 0x60, 0x80, 0x72, 0xe6, 0xc7, 0xee, 0xce, 0xff, 0xff }; static const unsigned char s_g57[] = { 0xee, 0xce, 0xe0, 0xc3, 0xc0, 0x87, 0x75, 0x67, 0x20, 0x23, 0x00, 0x2e, 0x0e, 0xff, 0xff }; static const unsigned char s_g58[] = { 0x00, 0x20, 0x02, 0x75, 0x57, 0x97, 0x79, 0xec, 0xce, 0xee, 0xff, 0xe0, 0xe2, 0xc0, 0x97, 0x75, 0xff, 0x0e, 0x0c, 0x2e, 0x57, 0x79, 0xff, 0xff }; static const unsigned char s_g59[] = { 0x0e, 0x0c, 0x2e, 0x66, 0x79, 0x86, 0xce, 0xec, 0xee, 0xff, 0x60, 0x80, 0x66, 0x86, 0xff, 0xff }; static const unsigned char s_g5A[] = { 0x0e, 0x0c, 0xee, 0xbc, 0xec, 0x02, 0x32, 0x00, 0xe2, 0xe0, 0xff, 0xff }; static const unsigned char s_g5B[] = { 0xa0, 0xa2, 0x60, 0x82, 0x6e, 0x8c, 0xae, 0xac, 0xff, 0xff }; static const unsigned char s_g5C[] = { 0xe0, 0xe2, 0xc0, 0x2e, 0x0c, 0x0e, 0xff, 0xff }; static const unsigned char s_g5D[] = { 0x4e, 0x4c, 0x8e, 0x6c, 0x80, 0x62, 0x40, 0x42, 0xff, 0xff }; static const unsigned char s_g5E[] = { 0x3a, 0x6a, 0x7e, 0x7b, 0xba, 0x8a, 0xff, 0xff }; static const unsigned char s_g5F[] = { 0x02, 0x00, 0xe2, 0xe0, 0xff, 0xff }; static const unsigned char s_g60[] = { 0x8a, 0x8e, 0x6c, 0x6e, 0xff, 0xff }; static const unsigned char s_g61[] = { 0x08, 0x27, 0x2a, 0x38, 0xca, 0xb8, 0xe8, 0xc7, 0xe6, 0xc6, 0xe4, 0xc4, 0xe0, 0xc2, 0x20, 0x32, 0x02, 0x23, 0x04, 0x34, 0x26, 0xc4, 0xc6, 0xff, 0xff }; static const unsigned char s_g62[] = { 0x2e, 0x0e, 0x2a, 0x09, 0x28, 0x00, 0x22, 0xc0, 0xb2, 0xe2, 0xc3, 0xe8, 0xc7, 0xca, 0xb8, 0x2a, 0x28, 0xff, 0xff }; static const unsigned char s_g63[] = { 0xc7, 0xe8, 0xb8, 0xca, 0x38, 0x2a, 0x27, 0x08, 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xff, 0xff }; static const unsigned char s_g64[] = { 0xc8, 0xca, 0x38, 0x2a, 0x27, 0x08, 0x23, 0x02, 0x32, 0x20, 0xc2, 0xe0, 0xc8, 0xe9, 0xca, 0xee, 0xce, 0xff, 0xff }; static const unsigned char s_g65[] = { 0xe2, 0xc3, 0xc0, 0xb2, 0x20, 0x32, 0x02, 0x23, 0x04, 0x24, 0x06, 0x26, 0x08, 0x27, 0x2a, 0x38, 0xca, 0xb8, 0xe8, 0xc7, 0xe4, 0xc6, 0x24, 0x26, 0xff, 0xff }; static const unsigned char s_g66[] = { 0x4a, 0x48, 0x6a, 0x68, 0x8a, 0x88, 0xaa, 0xa8, 0xff, 0x60, 0x80, 0x68, 0x88, 0xff, 0x6a, 0x8a, 0x6c, 0x8b, 0x8e, 0x9c, 0xae, 0xac, 0xff, 0xff }; static const unsigned char s_g67[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc4, 0xe6, 0xc6, 0xea, 0xc8, 0x2a, 0x38, 0x08, 0x27, 0x06, 0x36, 0x24, 0xc6, 0xc4, 0xff, 0xff }; static const unsigned char s_g68[] = { 0x00, 0x20, 0x08, 0x28, 0x0a, 0x2a, 0x0e, 0x2e, 0xff, 0x2a, 0x28, 0xca, 0xb8, 0xe8, 0xc7, 0xe0, 0xc0, 0xff, 0xff }; static const unsigned char s_g69[] = { 0x60, 0x80, 0x6a, 0x8a, 0xff, 0x6c, 0x8c, 0x6e, 0x8e, 0xff, 0xff }; static const unsigned char s_g6A[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xca, 0xea, 0xff, 0xcc, 0xec, 0xce, 0xee, 0xff, 0xff }; static const unsigned char s_g6B[] = { 0x00, 0x20, 0x04, 0x24, 0x06, 0x26, 0x0e, 0x2e, 0xff, 0x26, 0x24, 0x86, 0x84, 0xb5, 0xc0, 0xe2, 0xe0, 0xff, 0x86, 0xb5, 0xca, 0xe8, 0xea, 0xff, 0xff }; static const unsigned char s_g6C[] = { 0x60, 0x80, 0x6e, 0x8e, 0xff, 0xff }; static const unsigned char s_g6D[] = { 0x00, 0x20, 0x0a, 0x28, 0x6a, 0x68, 0xff, 0x60, 0x80, 0x68, 0x88, 0x6a, 0xb8, 0xca, 0xc7, 0xe8, 0xc0, 0xe0, 0xff, 0xff }; static const unsigned char s_g6E[] = { 0x00, 0x20, 0x0a, 0x28, 0xca, 0xb8, 0xe8, 0xc7, 0xe0, 0xc0, 0xff, 0xff }; static const unsigned char s_g6F[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc7, 0xe8, 0xb8, 0xca, 0x38, 0x2a, 0x27, 0x08, 0x23, 0x02, 0xff, 0xff }; static const unsigned char s_g70[] = { 0x00, 0x20, 0x04, 0x24, 0x06, 0x26, 0x0a, 0x28, 0xca, 0xb8, 0xe8, 0xc7, 0xe6, 0xb6, 0xc4, 0x26, 0x24, 0xff, 0xff }; static const unsigned char s_g71[] = { 0xc0, 0xe0, 0xc4, 0xe5, 0xc6, 0xea, 0xc8, 0x2a, 0x38, 0x08, 0x27, 0x06, 0x36, 0x24, 0xc6, 0xc4, 0xff, 0xff }; static const unsigned char s_g72[] = { 0x00, 0x20, 0x0a, 0x28, 0xca, 0xb8, 0xe8, 0xc7, 0xff, 0xff }; static const unsigned char s_g73[] = { 0xc3, 0xe4, 0xb4, 0xc6, 0x24, 0x36, 0x06, 0x27, 0x08, 0x38, 0x2a, 0xb8, 0xca, 0xc7, 0xe8, 0xff, 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xe4, 0xff, 0xff }; static const unsigned char s_g74[] = { 0x4a, 0x48, 0x6a, 0x68, 0xff, 0x8a, 0x88, 0xaa, 0xa8, 0xff, 0xa0, 0xa2, 0x80, 0x92, 0x62, 0x83, 0x68, 0x88, 0x6a, 0x8a, 0x6c, 0x8c, 0xff, 0xff }; static const unsigned char s_g75[] = { 0x2a, 0x0a, 0x23, 0x02, 0x32, 0x20, 0xc2, 0xe0, 0xca, 0xea, 0xff, 0xff }; static const unsigned char s_g76[] = { 0xea, 0xca, 0xe6, 0xc7, 0x80, 0x72, 0x60, 0x27, 0x06, 0x2a, 0x0a, 0xff, 0xff }; static const unsigned char s_g77[] = { 0x2a, 0x0a, 0x22, 0x00, 0x52, 0x60, 0x63, 0x71, 0x83, 0x80, 0x92, 0xc0, 0xb2, 0xe2, 0xc3, 0xea, 0xca, 0xff, 0x8a, 0x6a, 0x83, 0x63, 0xff, 0xff }; static const unsigned char s_g78[] = { 0x00, 0x20, 0x02, 0x74, 0x45, 0x76, 0x08, 0x2a, 0x0a, 0xff, 0xea, 0xca, 0xe8, 0x76, 0xa5, 0x74, 0xe2, 0xc0, 0xe0, 0xff, 0xff }; static const unsigned char s_g79[] = { 0x23, 0x02, 0x32, 0x20, 0xb2, 0xc0, 0xc3, 0xe2, 0xc4, 0xe5, 0xc6, 0xea, 0xca, 0xff, 0x2a, 0x0a, 0x27, 0x06, 0x36, 0x24, 0xc6, 0xc4, 0xff, 0xff }; static const unsigned char s_g7A[] = { 0x0a, 0x08, 0xea, 0xa8, 0xe8, 0x02, 0x42, 0x00, 0xe2, 0xe0, 0xff, 0xff }; static const unsigned char s_g7B[] = { 0x80, 0xa0, 0x62, 0x82, 0x66, 0x86, 0x57, 0x77, 0x68, 0x88, 0x6c, 0x8c, 0x8e, 0xae, 0xff, 0xff }; static const unsigned char s_g7C[] = { 0x60, 0x80, 0x6f, 0x8f, 0xff, 0xff }; static const unsigned char s_g7D[] = { 0x6e, 0x4e, 0x8c, 0x6c, 0x88, 0x68, 0x97, 0x77, 0x86, 0x66, 0x82, 0x62, 0x60, 0x40, 0xff, 0xff }; static const unsigned char s_g7E[] = { 0xbc, 0xbe, 0x9a, 0x9c, 0x5c, 0x5e, 0x3a, 0x3c, 0xff, 0xff }; static const unsigned char s_g7F[] = { 0x44, 0x22, 0xa4, 0xc2, 0xaa, 0xcc, 0x4a, 0x2c, 0x44, 0x22, 0xff, 0xff }; static const unsigned char *s_stroke[] = { s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g7F, s_g20, s_g21, s_g22, s_g23, s_g24, s_g25, s_g26, s_g27, s_g28, s_g29, s_g2A, s_g2B, s_g2C, s_g2D, s_g2E, s_g2F, s_g30, s_g31, s_g32, s_g33, s_g34, s_g35, s_g36, s_g37, s_g38, s_g39, s_g3A, s_g3B, s_g3C, s_g3D, s_g3E, s_g3F, s_g40, s_g41, s_g42, s_g43, s_g44, s_g45, s_g46, s_g47, s_g48, s_g49, s_g4A, s_g4B, s_g4C, s_g4D, s_g4E, s_g4F, s_g50, s_g51, s_g52, s_g53, s_g54, s_g55, s_g56, s_g57, s_g58, s_g59, s_g5A, s_g5B, s_g5C, s_g5D, s_g5E, s_g5F, s_g60, s_g61, s_g62, s_g63, s_g64, s_g65, s_g66, s_g67, s_g68, s_g69, s_g6A, s_g6B, s_g6C, s_g6D, s_g6E, s_g6F, s_g70, s_g71, s_g72, s_g73, s_g74, s_g75, s_g76, s_g77, s_g78, s_g79, s_g7A, s_g7B, s_g7C, s_g7D, s_g7E, s_g7F }; /* * Static local (to this module) functions */ static void glgdStrokePushAttributes(void) { glPushAttrib(GL_ENABLE_BIT); glGetIntegerv(GL_BLEND_SRC, &s_blendFunc[0]); glGetIntegerv(GL_BLEND_DST, &s_blendFunc[1]); /* Common attributes for primitive drawing */ glDisable(GL_TEXTURE_2D); glDisable(GL_LIGHTING); glDisable(GL_DEPTH_TEST); glDisable(GL_CULL_FACE); } static void glgdStrokePopAttributes(void) { glPopAttrib(); glBlendFunc(s_blendFunc[0], s_blendFunc[1]); } /* * External public functions */ glgdStroke *glgdStrokeCreate(void) { glgdStroke *stroke; stroke = (glgdStroke *)GLGD_MALLOC(sizeof(glgdStroke)); if (stroke) { glgdStrokeInit(stroke); } return stroke; } glgdStroke *glgdStrokeDestroy(glgdStroke *stroke) { if (stroke) { GLGD_FREE(stroke); } return (glgdStroke *)NULL; } void glgdStrokeInit(glgdStroke *stroke) { if (stroke) { stroke->flags = GLGDSTROKE_FLAG_INITIALIZED; stroke->tabSize = GLGDSTROKE_TABSIZE_DEFAULT; stroke->windowDim[0] = 640.0; stroke->windowDim[1] = 480.0; stroke->pointSize[0] = GLGDSTROKE_POINTSIZEX_DEFAULT; stroke->pointSize[1] = GLGDSTROKE_POINTSIZEY_DEFAULT; stroke->pos[0] = 0.0; stroke->pos[1] = 0.0; glgdStrokeClipFullWindow(stroke); stroke->col[0] = 1.0; stroke->col[1] = 1.0; stroke->col[2] = 1.0; stroke->col[3] = 1.0; } } void glgdStrokeFini(glgdStroke *stroke) { glgdStrokeInit(stroke); } glgdStroke *glgdStrokeGetCurrent(void) { return s_currentStroke; } void glgdStrokeSetCurrent(glgdStroke *stroke) { s_currentStroke = stroke; } int glgdStrokePrint(glgdStroke *stroke, const char *fmt, ...) { int rc; va_list args; va_start(args, fmt); rc = glgdStrokePrintVar(fmt, args); va_end(args); return rc; } int glgdStrokePrintVar(const char *fmt, va_list ap) { int rc; int vtxNdx; char str[256]; char *c; glgdStroke *stroke; rc = 0; stroke = glgdStrokeGetCurrent(); if (stroke) { /* Restrict string to 255 characters */ rc = vsnprintf(str, 255, fmt, ap); /* Initialize the rendering */ glgdStrokePushAttributes(); glBegin(GL_TRIANGLE_STRIP); /* Set the text color */ if (stroke->col[3] < 1.0) { glEnable(GL_BLEND); glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); glColor4d(stroke->col[0], stroke->col[1], stroke->col[2], stroke->col[3]); } else { glDisable(GL_BLEND); glColor3d(stroke->col[0], stroke->col[1], stroke->col[2]); } /* Submit the vertices for the string */ vtxNdx = 0; c = &str[0]; while (*c) { vtxNdx = glgdStrokeBuild(stroke, *c, vtxNdx); c++; } glEnd(); glgdStrokePopAttributes(); } return rc; } void glgdStrokeTabSizeSet(glgdStroke *stroke, int tabSize) { if (stroke) { if (tabSize < 0) { stroke->tabSize = GLGDSTROKE_TABSIZE_DEFAULT; } else { stroke->tabSize = tabSize; } } } void glgdStrokePointSizeSet(glgdStroke *stroke, glgdVec2 pointSize) { if (stroke) { if (pointSize[0] < 0.0 || pointSize[1] < 0.0) { stroke->pointSize[0] = GLGDSTROKE_POINTSIZEX_DEFAULT; stroke->pointSize[1] = GLGDSTROKE_POINTSIZEY_DEFAULT; } else { stroke->pointSize[0] = pointSize[0]; stroke->pointSize[1] = pointSize[1]; } } } void glgdStrokePointSizeSetByList ( glgdStroke *stroke, GLdouble w, GLdouble h ) { if (stroke) { if (w < 0.0 || h < 0.0) { stroke->pointSize[0] = GLGDSTROKE_POINTSIZEX_DEFAULT; stroke->pointSize[1] = GLGDSTROKE_POINTSIZEY_DEFAULT; } else { stroke->pointSize[0] = w; stroke->pointSize[1] = h; } } } void glgdStrokePosSet(glgdStroke *stroke, glgdVec2 pos) { if (stroke) { stroke->pos[0] = pos[0]; stroke->pos[1] = pos[1]; } } void glgdStrokePosSetByList(glgdStroke *stroke, GLdouble x, GLdouble y) { if (stroke) { stroke->pos[0] = x; stroke->pos[1] = y; } } void glgdStrokeWindowDimSet(glgdStroke *stroke, glgdVec2 windowDim) { if (stroke) { stroke->windowDim[0] = windowDim[0]; stroke->windowDim[1] = windowDim[1]; } } void glgdStrokeWindowDimSetByList(glgdStroke *stroke, GLdouble w, GLdouble h) { if (stroke) { stroke->windowDim[0] = w; stroke->windowDim[1] = h; } } void glgdStrokeClipFullWindow(glgdStroke *stroke) { if (stroke) { stroke->clip[0] = 0.0; stroke->clip[1] = 0.0; stroke->clip[2] = stroke->windowDim[0]; stroke->clip[3] = stroke->windowDim[1]; } } void glgdStrokeClipSet(glgdStroke *stroke, glgdVec4 clipRect) { if (stroke) { stroke->clip[0] = clipRect[0]; stroke->clip[1] = clipRect[1]; stroke->clip[2] = clipRect[2]; stroke->clip[3] = clipRect[3]; } } void glgdStrokeClipSetByList ( glgdStroke *stroke, GLdouble x1, GLdouble y1, GLdouble x2, GLdouble y2 ) { if (stroke) { stroke->clip[0] = x1; stroke->clip[1] = y1; stroke->clip[2] = x2; stroke->clip[3] = y2; } } void glgdStrokeColorSet(glgdStroke *stroke, glgdVec4 col) { if (stroke) { stroke->col[0] = col[0]; stroke->col[1] = col[1]; stroke->col[2] = col[2]; stroke->col[3] = col[3]; } } void glgdStrokeColorSetByList ( glgdStroke *stroke, GLdouble r, GLdouble g, GLdouble b, GLdouble a ) { if (stroke) { stroke->col[0] = r; stroke->col[1] = g; stroke->col[2] = b; stroke->col[3] = a; } } int glgdStrokeBuild(glgdStroke *stroke, int charNdx, int ndx) { int i; GLdouble sx, sy; GLdouble x, y; static glgdVec2 vtx; if (!stroke) { return ndx; } if (charNdx < 0 || charNdx >= 128) { charNdx = 0; } if (charNdx == '\t') { stroke->pos[0] += stroke->pointSize[0] * stroke->tabSize; return ndx; } else if (charNdx == '\n') { stroke->pos[0] = stroke->clip[0]; stroke->pos[1] += stroke->pointSize[1]; return ndx; } /* Compute the (x,y) position of the glyph */ x = stroke->pos[0]; y = stroke->pos[1]; /* Submit the vertices for this glyph */ i = 0; sx = stroke->pointSize[0] * 0.0625; sy = stroke->pointSize[1] * 0.0625; while (s_stroke[charNdx][i] != 0xff) { /* Add degenerate triangle to link with next tri strip */ if (s_stroke[charNdx][i] != 0xff && ndx > 2) { /* Repeat last vertex */ glVertex2d(vtx[0], vtx[1]); ndx++; /* Submit this vertex */ vtx[0] = x + (s_stroke[charNdx][i] >> 4) * sx; if (stroke->flags & GLGDSTROKE_FLAG_INVERT) { vtx[1] = y - (15 - (s_stroke[charNdx][i] % 16)) * sy; } else { vtx[1] = y + (15 - (s_stroke[charNdx][i] % 16)) * sy; } glVertex2d(vtx[0], vtx[1]); ndx++; } while (s_stroke[charNdx][i] != 0xff) { vtx[0] = x + (s_stroke[charNdx][i] >> 4) * sx; if (stroke->flags & GLGDSTROKE_FLAG_INVERT) { vtx[1] = y - (15 - (s_stroke[charNdx][i] % 16)) * sy; } else { vtx[1] = y + (15 - (s_stroke[charNdx][i] % 16)) * sy; } glVertex2d(vtx[0], vtx[1]); ndx++; i++; } i++; } /* Update the current position */ stroke->pos[0] += stroke->pointSize[0]; return ndx; } gauche-gtk-0.6+git20160927/glgd/glgdStroke.h000066400000000000000000000047711300401456300202100ustar00rootroot00000000000000/* * gldgStroke.h * * OpenGL Graph Display stroke font module header file * * Written by: Shawn Taras */ #ifndef __GLGDSTROKE_H__ #define __GLGDSTROKE_H__ SCM_DECL_BEGIN /* * Defines */ #define GLGDSTROKE_FLAG_INITIALIZED (0x0001) #define GLGDSTROKE_FLAG_CREATED (0x0002) #define GLGDSTROKE_FLAG_MODIF (0x0004) #define GLGDSTROKE_FLAG_INVERT (0x0008) #define GLGDSTROKE_POINTSIZEX_DEFAULT (8.0) #define GLGDSTROKE_POINTSIZEY_DEFAULT (16.0) #define GLGDSTROKE_TABSIZE_DEFAULT (2) /* * Type Definitions */ typedef struct _glgdStroke { GLbitfield flags; int tabSize; glgdVec2 windowDim; glgdVec2 pointSize; glgdVec2 pos; glgdVec4 clip; glgdColor col; } glgdStroke; /* * Module API */ glgdStroke *glgdStrokeCreate(void); glgdStroke *glgdStrokeDestroy(glgdStroke *stroke); void glgdStrokeInit(glgdStroke *stroke); void glgdStrokeFini(glgdStroke *stroke); glgdStroke *glgdStrokeGetCurrent(void); void glgdStrokeSetCurrent(glgdStroke *stroke); int glgdStrokePrint(glgdStroke *stroke, const char *fmt, ...); int glgdStrokePrintVar(const char *fmt, va_list ap); void glgdStrokeTabSizeSet(glgdStroke *stroke, int tabSize); void glgdStrokePointSizeSet(glgdStroke *stroke, glgdVec2 pointSize); void glgdStrokePointSizeSetByList(glgdStroke *stroke, GLdouble w, GLdouble h); void glgdStrokePosSet(glgdStroke *stroke, glgdVec2 pos); void glgdStrokePosSetByList(glgdStroke *stroke, GLdouble x, GLdouble y); void glgdStrokeWindowDimSet(glgdStroke *stroke, glgdVec2 windowDim); void glgdStrokeWindowDimSetByList(glgdStroke *stroke, GLdouble w, GLdouble h); void glgdStrokeClipFullWindow(glgdStroke *stroke); void glgdStrokeClipSet(glgdStroke *stroke, glgdVec4 clipRect); void glgdStrokeClipSetByList(glgdStroke *stroke, GLdouble x1, GLdouble y1, GLdouble x2, GLdouble y2); void glgdStrokeColorSet(glgdStroke *stroke, glgdVec4 col); void glgdStrokeColorSetByList(glgdStroke *stroke, GLdouble r, GLdouble g, GLdouble b, GLdouble a); int glgdStrokeBuild(glgdStroke *stroke, int charNdx, int ndx); SCM_DECL_END #endif /* __GLGDSTROKE_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdTexture.c000066400000000000000000000053351300401456300203710ustar00rootroot00000000000000/* * gldgTexture.c * * OpenGL Graph Display texture utility module implementation * * Written by: Shawn Taras */ #include #include #include #include "glgd.h" /* * Defines */ #define _SQR(x) ((x) * (x)) /* * External public functions */ glgdTexture *glgdTextureCreate(void) { glgdTexture *tex; tex = (glgdTexture *)GLGD_MALLOC(sizeof(glgdTexture)); if (tex) { glgdTextureInit(tex); } return tex; } glgdTexture *glgdTextureDestroy(glgdTexture *tex) { if (tex != NULL) { glgdTextureFini(tex); GLGD_FREE(tex); } return (glgdTexture *)NULL; } GLboolean glgdTextureInit(glgdTexture *tex) { if (tex != NULL) { tex->name = 0; tex->width = 0; tex->height = 0; tex->texels = NULL; return GL_TRUE; } return GL_FALSE; } GLboolean glgdTextureFini(glgdTexture *tex) { if (tex != NULL) { glDeleteTextures(1, &tex->name); if (tex->texels != NULL) { GLGD_FREE(tex->texels); } glgdTextureInit(tex); return GL_TRUE; } return GL_FALSE; } GLboolean glgdTextureSetup(glgdTexture *tex, int width, int height) { GLint widthSet; GLint heightSet; GLvoid *texels; glGetIntegerv(GL_MAX_TEXTURE_SIZE, &widthSet); glgdTrace(1, "GL_MAX_TEXTURE_SIZE = %d\n", widthSet); /* Create the texture */ if (tex) { glTexImage2D(GL_PROXY_TEXTURE_2D, 0, GL_RGBA, width, height, 0, GL_RGBA, GL_UNSIGNED_BYTE, NULL); /* Check for valid (width,height) parameters */ glGetTexLevelParameteriv(GL_PROXY_TEXTURE_2D, 0, GL_TEXTURE_WIDTH, &widthSet); glGetTexLevelParameteriv(GL_PROXY_TEXTURE_2D, 0, GL_TEXTURE_HEIGHT, &heightSet); if (widthSet == 0 || heightSet == 0) { return GL_FALSE; } texels = GLGD_MALLOC(width * height * 4); memset(texels, 0, width * height * 4); glPixelStorei(GL_UNPACK_ALIGNMENT, 4); glGenTextures(1, &tex->name); glBindTexture(GL_TEXTURE_2D, tex->name); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, width, height, 0, GL_RGBA, GL_UNSIGNED_BYTE, texels); tex->width = width; tex->height = height; tex->texels = texels; return GL_TRUE; } return GL_FALSE; } gauche-gtk-0.6+git20160927/glgd/glgdTexture.h000066400000000000000000000012431300401456300203700ustar00rootroot00000000000000/* * gldgTexture.h * * OpenGL Graph Display texture utility module header file * * Written by: Shawn Taras */ #ifndef __GLGDTEXTURE_H__ #define __GLGDTEXTURE_H__ SCM_DECL_BEGIN /* * Type Definitions */ typedef struct _glgdTexture { GLuint name; GLsizei width; GLsizei height; GLvoid *texels; } glgdTexture; /* * Module API */ glgdTexture *glgdTextureCreate(void); glgdTexture *glgdTextureDestroy(glgdTexture *tex); GLboolean glgdTextureInit(glgdTexture *tex); GLboolean glgdTextureFini(glgdTexture *tex); GLboolean glgdTextureSetup(glgdTexture *tex, int width, int height); SCM_DECL_END #endif /* __GLGDTEXTURE_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdTypes.h000066400000000000000000000006161300401456300200370ustar00rootroot00000000000000/* * glgdTypes.h * * OpenGL Graph Display library common type definitions * * Written by: Shawn Taras */ #ifndef __GLGDTYPES_H__ #define __GLGDTYPES_H__ SCM_DECL_BEGIN /* * Type Definitions */ typedef GLdouble glgdVec2[2]; typedef GLdouble glgdVec3[3]; typedef GLdouble glgdVec4[4]; typedef GLdouble glgdColor[4]; SCM_DECL_END #endif /* __GLGDTYPES_H__ */ gauche-gtk-0.6+git20160927/glgd/glgdlib.stub000066400000000000000000000241401300401456300202250ustar00rootroot00000000000000;;; ;;; glgdlib.stub ;;; ;;; Copyright(C) 2004 by Shawn Taras (staras@cementedminds.com) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: glgdlib.stub,v 1.28 2007/01/13 01:36:30 maruska Exp $ ;;; (include "glgd.types") "#include \"gauche-glgd.h\"" ;;================================================================= ;; glgdDefines.h (define-enum GLGD_FLAGOP_CLEAR) (define-enum GLGD_FLAGOP_SET) (define-enum GLGD_FLAGOP_TOGGLE) (define-enum GLGD_ATTR_FORCEVISIBLE) ;;================================================================= ;; glgdNode.h ;; (define-enum GLGDNODE_FLAG_HILITE) (define-enum GLGDNODE_FLAG_DIM) (define-enum GLGDNODE_FLAG_SELECTED) (define-cproc glgd-node-create () :: glgdNodeCreate) (define-cproc glgd-node-destroy (node::) :: glgdNodeDestroy) (define-cproc glgd-node-init (node::) :: glgdNodeInit) (define-cproc glgd-node-label-set (node:: label::) :: glgdNodeLabelSet) (define-cproc glgd-node-label-get (node::) glgdNodeLabelGet) (define-cproc glgd-node-data-set (node:: data) :: glgdNodeDataSet) (define-cproc glgd-node-data-get (node::) glgdNodeDataGet) (define-cproc glgd-node-id-set (node:: id::) :: glgdNodeIDSet) (define-cproc glgd-node-id-get (node::) :: glgdNodeIDGet) (define-cproc glgd-node-info-set (node:: label:: id::) :: glgdNodeInfoSet) (define-cproc glgd-node-flags-set (node:: mask:: flagop::) :: glgdNodeFlagsSet) (define-cproc glgd-node-is-selected (node::) :: glgdNodeIsSelected) (define-cproc glgd-node-color-default (r:: g:: b:: a::) :: glgdNodeColorDefault) (define-cproc glgd-node-color-set (node:: r:: g:: b:: a::) :: glgdNodeColorSetByList) (define-cproc glgd-node-attribute-clear (node::) :: glgdNodeAttributeClear) (define-cproc glgd-node-attribute-set (node:: attrNdx::) :: glgdNodeAttributeSet) (define-cproc glgd-node-attribute-reset (node:: attrNdx::) :: glgdNodeAttributeReset) (define-cproc glgd-node-attribute-is-set (node:: attrNdx::) :: glgdNodeAttributeIsSet) ;;================================================================= ;; glgdLink.h ;; (define-cproc glgd-link-create () :: glgdLinkCreate) (define-cproc glgd-link-destroy (link::) :: glgdLinkDestroy) (define-cproc glgd-link-init (link::) :: glgdLinkInit) (define-cproc glgd-link-set (link:: src:: dst::) :: glgdLinkSet) (define-cproc glgd-link-flags-set (link:: mask:: flagop::) :: glgdLinkFlagsSet) (define-cproc glgd-link-list-create () :: glgdLinkListCreate) (define-cproc glgd-link-list-destroy (list::) :: glgdLinkListDestroy) (define-cproc glgd-link-list-init (list::) :: glgdLinkListInit) (define-cproc glgd-link-list-flags-set (list:: mask:: flagop::) :: glgdLinkListFlagsSet) ;;================================================================= ;; glgdGraph.h ;; (define-enum GLGDGRAPH_FN_MOUSE_LEFT) (define-enum GLGDGRAPH_FN_MOUSE_MIDDLE) (define-enum GLGDGRAPH_FN_MOUSE_RIGHT) (define-enum GLGDGRAPH_FN_MOUSE_SCROLL) (define-enum GLGDGRAPH_FN_MOUSE_HOVER) (define-enum GLGDGRAPH_FN_KEY) (define-enum GLGDGRAPH_FN_PRERENDER) (define-enum GLGDGRAPH_FLAG_CTRLHELD) (define-enum GLGDGRAPH_FLAG_ESCPRESSED) (define-enum GLGDGRAPH_FLAG_PANGOBOLD) (define-cproc glgd-graph-create () :: glgdGraphCreate) (define-cproc glgd-graph-destroy (graph::) :: glgdGraphDestroy) (define-cproc glgd-graph-init (graph::) :: glgdGraphInit) (define-cproc glgd-graph-fini (graph::) :: glgdGraphFini) (define-cproc glgd-graph-draw (graph::) :: glgdGraphDraw) (define-cproc glgd-graph-frame (graph::) :: glgdGraphFrame) (define-cproc glgd-graph-invalidate (graph::) :: glgdGraphInvalidate) (define-cproc glgd-graph-reshape (graph::) :: glgdGraphReshape) ;; NB: the three-argument variant is kept only for backward compatibility. (define-cproc glgd-graph-connect (graph:: widget:: &optional w2) "int r; if (SCM_UNBOUNDP(w2)) { r = glgdGraphConnect(graph, widget); } else { r = glgdGraphConnect3(graph, widget, w2); } SCM_RETURN(SCM_MAKE_BOOL(r));") (define-cproc glgd-graph-translate (graph:: x:: y::) :: glgdGraphTranslate) (define-cproc glgd-graph-center (graph::) :: glgdGraphCenter) (define-cproc glgd-graph-auto-organize (graph:: x:: y::) :: glgdGraphAutoOrganizeXY) (define-cproc glgd-graph-node-by-id (graph:: node-id::) :: glgdGraphNodeByID) (define-cproc glgd-graph-node-selected (graph:: select-index::) :: glgdGraphNodeSelected) (define-cproc glgd-graph-node-select-count (graph::) :: glgdGraphNodeSelectCount) (define-cproc glgd-graph-node-count (graph::) :: glgdGraphNodeCount) (define-cproc glgd-graph-node-add (graph:: node::) :: glgdGraphNodeAdd) (define-cproc glgd-graph-node-list-flag (graph:: flag-mask:: flag-op::) :: glgdGraphNodeListFlag) (define-cproc glgd-graph-link-list-add (graph:: list::) :: glgdGraphLinkListAdd) (define-cproc glgd-graph-link-list-dump (graph::) :: glgdGraphLinkListDump) (define-cproc glgd-graph-link-add (graph:: list:: link::) :: glgdGraphLinkAdd) (define-cproc glgd-graph-link-index (graph:: link::) :: glgdGraphLinkNdx) (define-cproc glgd-graph-link-by-index (graph:: index::) :: glgdGraphLinkByNdx) (define-cproc glgd-graph-callback-set (graph:: fn-type:: fn) :: glgdGraphCallbackSet) (define-cproc glgd-graph-flags-set (graph:: flag-mask:: flag-op::) :: glgdGraphFlagsSet) (define-cproc glgd-graph-dim-set (graph:: w:: h::) :: glgdGraphDimSetByList) (define-cproc glgd-graph-margin-set (graph:: margin::) :: glgdGraphMarginSet) (define-cproc glgd-graph-margin-get (graph::) :: glgdGraphMarginGet) (define-cproc glgd-graph-line-color-set (graph:: r:: g:: b:: a::) :: glgdGraphLineColorSetByList) (define-cproc glgd-graph-attribute-clear (graph::) :: glgdGraphAttributeClear) (define-cproc glgd-graph-attribute-set (graph:: attrNdx::) :: glgdGraphAttributeSet) (define-cproc glgd-graph-attribute-toggle (graph:: attrNdx::) :: glgdGraphAttributeToggle) (define-cproc glgd-graph-attribute-reset (graph:: attrNdx::) :: glgdGraphAttributeReset) (define-cproc glgd-graph-attribute-is-set (graph:: attrNdx::) :: glgdGraphAttributeIsSet) (define-cproc glgd-verbosity (level::) :: glgdVerbosity) ;; Local variables: ;; mode: scheme ;; end: gauche-gtk-0.6+git20160927/glgd/test.scm000066400000000000000000000002061300401456300174020ustar00rootroot00000000000000(add-load-path "../gtkgl") (use gtk) (use gauche.test) (test-start "GtkGLGD") (use gtk.glgd) (test-module 'gtk.glgd) (test-end) gauche-gtk-0.6+git20160927/gtkgl/000077500000000000000000000000001300401456300161145ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/gtkgl/Makefile.in000066400000000000000000000053301300401456300201620ustar00rootroot00000000000000# # Makefile.in for Gauche-gtk/gtkgl # # prelude --------------------------------------------- .SUFFIXES: .stub .stub.c : $(GOSH) genstub $< # General info SHELL = @SHELL@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ datarootdir = @datarootdir@ srcdir = @srcdir@ VPATH = $(srcdir) top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ # These may be overridden by make invocators DESTDIR = # These are set by configure # NB: cc and various flags must match the ones used to compile Gauche, # so the make invocator shouldn't casually override them. CC = @CC@ CFLAGS = @DEFS@ @CFLAGS@ @X_CFLAGS@ `gauche-config -I` `gauche-config --so-cflags` $(GTKGL_CFLAGS) LDFLAGS = $(GTKGL_LDFLAGS) @LDFLAGS@ `gauche-config -L` `gauche-config --so-ldflags` LIBS = $(GTKGL_LIBS) @LIBS@ `gauche-config -l` @X_LIBS@ @X_PRE_LIBS@ -lXext -lX11 GOSH = @GOSH@ GAUCHE_CONFIG = @GAUCHE_CONFIG@ INSTALL = @GAUCHE_INSTALL@ OBJEXT = @OBJEXT@ EXEEXT = @EXEEXT@ SOEXT = @SOEXT@ # Other definitions GTKGL_CFLAGS = `pkg-config --cflags gtkglext-1.0` GTKGL_LDFLAGS = `pkg-config --libs-only-L gtkglext-1.0` GTKGL_LIBS = `pkg-config --libs-only-l gtkglext-1.0` ARCHFILES = gauche-gtkgl.$(SOEXT) SCMFILES = gtkgl.scm SCMFILEDIR = $(top_srcdir)/lib/gtk HEADERS = GAUCHE_PKGINCDIR = $(DESTDIR)@GAUCHE_PKGINCDIR@ GAUCHE_PKGLIBDIR = $(DESTDIR)@GAUCHE_PKGLIBDIR@/gtk GAUCHE_PKGARCHDIR = $(DESTDIR)@GAUCHE_PKGARCHDIR@ # build ----------------------------------------------- TARGET = $(ARCHFILES) OBJS = gtkgl_head.$(OBJEXT) gauche-gtkgl.$(OBJEXT) \ gdkgllib.$(OBJEXT) gtkgllib.$(OBJEXT) \ gtkgl_tail.$(OBJEXT) CONFIG_GENERATED = Makefile config.cache config.log config.status GENERATED = gdkgllib.c gtkgllib.c gtkgl_head.c gtkgl_tail.c all : $(TARGET) gauche-gtkgl.$(SOEXT) : $(OBJS) $(CC) $(LDFLAGS) gauche-gtkgl.$(SOEXT) $(OBJS) $(LIBS) $(OBJS) : gauche-gtkgl.h gdkgllib.c : gdkgllib.stub gtkgllib.c : gtkgllib.stub gtkgl_head.c gtkgl_tail.c : $(GAUCHE_CONFIG) --fixup-extension gtkgl gauche_gtkgl # tests ----------------------------------------------- check : all @rm -f test.log $(GOSH) -I. -I../src -I../lib test.scm >> test.log # install ---------------------------------------------- install : all $(INSTALL) -m 444 -T $(GAUCHE_PKGINCDIR) $(HEADERS) $(INSTALL) -m 444 -T $(GAUCHE_PKGLIBDIR) -S $(SCMFILEDIR) $(SCMFILES) $(INSTALL) -m 555 -T $(GAUCHE_PKGARCHDIR) $(ARCHFILES) # clean ------------------------------------------------ clean : rm -rf core $(TARGET) $(OBJS) $(GLOBJS) $(GENERATED) *~ test.log so_locations distclean : clean rm -rf $(CONFIG_GENERATED) maintainer-clean : clean rm -rf $(CONFIG_GENERATED) configure gauche-gtk-0.6+git20160927/gtkgl/gauche-gtkgl.c000066400000000000000000000033551300401456300206300ustar00rootroot00000000000000/* * gauche-gtkgl.h - Gauche+Gtkglarea extension * * Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in all * distributions. * This software is provided as is, without express or implied * warranty. In no circumstances the author(s) shall be liable * for any damages arising out of the use of this software. * * $Id: gauche-gtkgl.c,v 1.4 2007/01/13 01:36:30 maruska Exp $ */ #include "gauche-gtkgl.h" #ifdef HAVE_GTKGL /*==================================================================== * Basic data converters */ int *Scm_ListToGdkGLAttribList(ScmObj attrib) { int len = Scm_Length(attrib), *alist, i; ScmObj ap; if (len < 0 || (len % 2) != 0) { Scm_Error("attribute list must have even number of elements, but got %S", attrib); } alist = SCM_NEW_ATOMIC2(int*, sizeof(int)*(len+1)); i = 0; SCM_FOR_EACH(ap, attrib) { if (!SCM_EXACTP(SCM_CAR(ap))) { Scm_Error("integer expected in attibute list, but got %S", SCM_CAR(ap)); } alist[i++] = Scm_GetInteger(SCM_CAR(ap)); } alist[i] = GDK_GL_ATTRIB_LIST_NONE; return alist; } /* * Initialization */ extern void Scm_Init_gdkgllib(ScmModule *); extern void Scm_Init_gtkgllib(ScmModule *); void Scm_Init_gauche_gtkgl(void) { ScmModule *mod; SCM_INIT_EXTENSION(gauche_gtkgl); mod = SCM_MODULE(SCM_FIND_MODULE("gtk.gtkgl", TRUE)); Scm_Init_gdkgllib(mod); Scm_Init_gtkgllib(mod); } #endif /*HAVE_GTKGL*/ gauche-gtk-0.6+git20160927/gtkgl/gauche-gtkgl.h000066400000000000000000000063031300401456300206310ustar00rootroot00000000000000/* * gauche-gtkgl.h - Gauche+GtkGLExt extension * * Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in all * distributions. * This software is provided as is, without express or implied * warranty. In no circumstances the author(s) shall be liable * for any damages arising out of the use of this software. * * $Id: gauche-gtkgl.h,v 1.5 2007/01/13 01:36:30 maruska Exp $ */ #ifndef GAUCHE_GTKGL_H #define GAUCHE_GTKGL_H #include #include #include "../src/gauche-gtk.h" #include "../src/gtk-config.h" #ifdef HAVE_GTKGL SCM_DECL_BEGIN /*==================================================================== * Basic data converters */ extern int *Scm_ListToGdkGLAttribList(ScmObj attrib); /*==================================================================== * gdkgl classes */ /* GdkGLConfig */ SCM_CLASS_DECL(Scm_GdkGLConfigClass); #define SCM_CLASS_GDK_GL_CONFIG (&Scm_GdkGLConfigClass) #define SCM_GDK_GL_CONFIG_P(obj) (Scm_TypeP(obj, SCM_CLASS_GDK_GL_CONFIG)) #define SCM_GDK_GL_CONFIG(obj) SCM_GOBJECT_UNBOX(GDK_GL_CONFIG, obj) #define SCM_MAKE_GDK_GL_CONFIG(obj) SCM_GOBJECT_BOX(obj) #define SCM_GDK_GL_CONFIG_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GDK_GL_CONFIG_P(obj)) /* GdkGLContext */ SCM_CLASS_DECL(Scm_GdkGLContextClass); #define SCM_CLASS_GDK_GL_CONTEXT (&Scm_GdkGLContextClass) #define SCM_GDK_GL_CONTEXT_P(obj) (Scm_TypeP(obj, SCM_CLASS_GDK_GL_CONTEXT)) #define SCM_GDK_GL_CONTEXT(obj) SCM_GOBJECT_UNBOX(GDK_GL_CONTEXT, obj) #define SCM_MAKE_GDK_GL_CONTEXT(obj) SCM_GOBJECT_BOX(obj) #define SCM_GDK_GL_CONTEXT_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GDK_GL_CONTEXT_P(obj)) /* GdkGLDrawable */ SCM_CLASS_DECL(Scm_GdkGLDrawableClass); #define SCM_CLASS_GDK_GL_DRAWABLE (&Scm_GdkGLDrawableClass) #define SCM_GDK_GL_DRAWABLE_P(obj) (Scm_TypeP(obj, SCM_CLASS_GDK_GL_DRAWABLE)) #define SCM_GDK_GL_DRAWABLE(obj) SCM_GOBJECT_UNBOX(GDK_GL_DRAWABLE, obj) #define SCM_MAKE_GDK_GL_DRAWABLE(obj) SCM_GOBJECT_BOX(obj) #define SCM_GDK_GL_DRAWABLE_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GDK_GL_DRAWABLE_P(obj)) /* GdkGLPixmap */ SCM_CLASS_DECL(Scm_GdkGLPixmapClass); #define SCM_CLASS_GDK_GL_PIXMAP (&Scm_GdkGLPixmapClass) #define SCM_GDK_GL_PIXMAP_P(obj) (Scm_TypeP(obj, SCM_CLASS_GDK_GL_PIXMAP)) #define SCM_GDK_GL_PIXMAP(obj) SCM_GOBJECT_UNBOX(GDK_GL_PIXMAP, obj) #define SCM_MAKE_GDK_GL_PIXMAP(obj) SCM_GOBJECT_BOX(obj) #define SCM_GDK_GL_PIXMAP_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GDK_GL_PIXMAP_P(obj)) /* GdkGLWindow */ SCM_CLASS_DECL(Scm_GdkGLWindowClass); #define SCM_CLASS_GDK_GL_WINDOW (&Scm_GdkGLWindowClass) #define SCM_GDK_GL_WINDOW_P(obj) (Scm_TypeP(obj, SCM_CLASS_GDK_GL_WINDOW)) #define SCM_GDK_GL_WINDOW(obj) SCM_GOBJECT_UNBOX(GDK_GL_WINDOW, obj) #define SCM_MAKE_GDK_GL_WINDOW(obj) SCM_GOBJECT_BOX(obj) #define SCM_GDK_GL_WINDOW_OR_NULL_P(obj) (SCM_FALSEP(obj)||SCM_GDK_GL_WINDOW_P(obj)) SCM_DECL_END #endif /*HAVE_GTKGL*/ #endif /*GAUCHE_GTK_H*/ gauche-gtk-0.6+git20160927/gtkgl/gdkgllib.stub000066400000000000000000000417241300401456300206020ustar00rootroot00000000000000;;; ;;; gdkgllib.stub - gdkglext binding ;;; ;;; Copyright(C) 2002-2003 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gdkgllib.stub,v 1.7 2007/08/22 17:06:38 maruska Exp $ ;;; ;; mmc: with Cgen, this must come first "#include \"gauche-gtkgl.h\"" (include "gtkgl.types") ;;================================================================= ;; gdkglconfig.h ;; (define-enum GDK_GL_MODE_RGB) (define-enum GDK_GL_MODE_RGBA) (define-enum GDK_GL_MODE_INDEX) (define-enum GDK_GL_MODE_SINGLE) (define-enum GDK_GL_MODE_DOUBLE) (define-enum GDK_GL_MODE_ACCUM) (define-enum GDK_GL_MODE_ALPHA) (define-enum GDK_GL_MODE_DEPTH) (define-enum GDK_GL_MODE_STENCIL) (define-enum GDK_GL_MODE_STEREO) ;(define-enum GDK_GL_MODE_MULTISAMPLE) ;removed @ gtkglext0.7 ;(define-enum GDK_GL_MODE_LUMINANCE) ;removed @ gtkglext0.7 (define-cclass "GdkGLConfig*" "Scm_GdkGLConfigClass" ("Scm_GObjectClass") (;;(screen :type :setter #f) ;;(colormap :type :setter #f) ;removed @ gtkglext0.7 ;;(depth :type :setter #f) ;removed @ gtkglext0.7 (layer-plane :type :setter #f) (is-rgba :type :setter #f) (is_double_buffered :type :setter #f) (as_single_mode :type :setter #f) (is_stereo :type :setter #f) (has_alpha :type :setter #f) (has_depth_buffer :type :setter #f) (has_stencil_buffer :type :setter #f) (has_accum_buffer :type :setter #f) ;;(is_multisample :type :setter #f) ;removed @ gtkglext0.7 ;;(is_luminance :type :setter #f) ;removed @ gtkglext0.7 ) ) (initcode "Scm_GtkRegisterClass(GDK_TYPE_GL_CONFIG, SCM_CLASS_GDK_GL_CONFIG);") (define-cproc gdk-gl-config-new (attrib::) "SCM_RETURN(SCM_MAKE_GDK_GL_CONFIG(gdk_gl_config_new(Scm_ListToGdkGLAttribList(attrib))));") ; gdk-gl-config-new-for-screen - not until GdkScreen support (define-cproc gdk-gl-config-new-by-mode (mode::) (call "gdk_gl_config_new_by_mode")) ; gdk-gl-config-get-screen - not until GdkScreen support (define-cproc gdk-gl-config-get-attrib (glconfig:: attrib::) "int value; gboolean r = gdk_gl_config_get_attrib(glconfig, attrib, &value); SCM_RETURN(Scm_Values2(SCM_MAKE_BOOL(r), Scm_MakeInteger(value)));") (define-cproc gdk-gl-config-get-colormap (glconfig::) (call "gdk_gl_config_get_colormap")) (define-cproc gdk-gl-config-get-visual (glconfig::) (call "gdk_gl_config_get_visual")) (define-cproc gdk-gl-config-get-depth (glconfig::) (call "gdk_gl_config_get_depth")) (define-cproc gdk-gl-config-is-rgba (glconfig::) (call "gdk_gl_config_is_rgba")) (define-cproc gdk-gl-config-is-double-buffered (glconfig::) (call "gdk_gl_config_is_double_buffered")) (define-cproc gdk-gl-config-is-stereo (glconfig::) (call "gdk_gl_config_is_stereo")) (define-cproc gdk-gl-config-has-alpha (glconfig::) (call "gdk_gl_config_has_alpha")) (define-cproc gdk-gl-config-has-depth-buffer (glconfig::) (call "gdk_gl_config_has_depth_buffer")) (define-cproc gdk-gl-config-has-stencil-buffer (glconfig::) (call "gdk_gl_config_has_stencil_buffer")) (define-cproc gdk-gl-config-has-accum-buffer (glconfig::) (call "gdk_gl_config_has_accum_buffer")) ;;================================================================= ;; gdkglcontext.h ;; (define-cclass "GdkGLContext*" "Scm_GdkGLContextClass" ("Scm_GObjectClass") (;;(gldrawable :type :setter #f) ;removed @gtkglext0.7 ;;(glconfig :type :setter #f) ;removed @gtkglext0.7 ;;(share-list :type :setter #f) ;removed @gtkglext0.7 ;;(is-direct :type :setter #f) ;removed @gtkglext0.7 ;;(render-type :type :setter #f) ;removed @gtkglext0.7 ) ) (initcode "Scm_GtkRegisterClass(GDK_TYPE_GL_CONTEXT, SCM_CLASS_GDK_GL_CONTEXT); ") (if "GDKGLEXT_CHECK_VERSION(0, 7, 0)" (define-cproc gdk-gl-context-new (gldrawable:: share-list::-or-null direct:: render-type::) (call "gdk_gl_context_new")) ) (if "!GDKGLEXT_CHECK_VERSION(0, 7, 0)" (define-cproc gdk-gl-context-new (gldrawable:: glconfig:: share-list::-or-null direct:: render-type::) (call "gdk_gl_context_new")) ) (define-cproc gdk-gl-context-copy! (dst:: src:: mask::) (call "gdk_gl_context_copy")) (define-cproc gdk-gl-context-get-gl-drawable (glcontext::) (call "gdk_gl_context_get_gl_drawable")) (define-cproc gdk-gl-context-get-gl-config (glcontext::) (call "gdk_gl_context_get_gl_config")) (define-cproc gdk-gl-context-is-direct (glcontext::) (call "gdk_gl_context_is_direct")) (define-cproc gdk-gl-context-get-render-type (glcontext::) (call "gdk_gl_context_get_render_type")) (if "!GDKGLEXT_CHECK_VERSION(0, 7, 0)" (define-cproc gdk-gl-context-get-colormap (glcontext::) (call "gdk_gl_context_get_colormap")) ) ;;================================================================= ;; gdkgldrawable.h ;; (define-cclass "GdkGLDrawable*" "Scm_GdkGLDrawableClass" ("Scm_GObjectClass") () ) (initcode "Scm_GtkRegisterClass(GDK_TYPE_GL_DRAWABLE, SCM_CLASS_GDK_GL_DRAWABLE);") (define-cproc gdk-gl-drawable-make-current (gldrawable:: glcontext::) (call "gdk_gl_drawable_make_current")) (define-cproc gdk-gl-drawable-is-double-buffered (gldrawable::) (call "gdk_gl_drawable_is_double_buffered")) (define-cproc gdk-gl-drawable-swap-buffers (gldrawable::) (call "gdk_gl_drawable_swap_buffers")) (define-cproc gdk-gl-drawable-wait-gl (gldrawable::) (call "gdk_gl_drawable_wait_gl")) (define-cproc gdk-gl-drawable-wait-gdk (gldrawable::) (call "gdk_gl_drawable_wait_gdk")) (define-cproc gdk-gl-drawable-gl-begin (gldrawable:: glcontext::) (call "gdk_gl_drawable_gl_begin")) (define-cproc gdk-gl-drawable-gl-end (gldrawable::) (call "gdk_gl_drawable_gl_end")) (define-cproc gdk-gl-drawable-get-gl-config (gldrawable::) (call "gdk_gl_drawable_get_gl_config")) (define-cproc gdk-gl-drawable-get-size (gldrawable::) "gint w, h; gdk_gl_drawable_get_size(gldrawable, &w, &h); SCM_RETURN(Scm_Values2(SCM_MAKE_INT(w), SCM_MAKE_INT(h)));") ;;================================================================= ;; gdkglfont.h ;; (define-cproc gdk-gl-font-use-pango-font (font-desc:: first:: count:: list-base::) (call "gdk_gl_font_use_pango_font")) ;;================================================================= ;; gdkglpixmap.h ;; (define-cclass "GdkGLPixmap*" "Scm_GdkGLPixmapClass" ("Scm_GdkGLDrawableClass" "Scm_GObjectClass") (;;(glconfig :type :setter #f);removed @ gtkglext0.7 (drawable :type :setter #f)) ) (initcode "Scm_GtkRegisterClass(GDK_TYPE_GL_PIXMAP, SCM_CLASS_GDK_GL_PIXMAP);") (define-cproc gdk-gl-pixmap-new (glconfig:: pixmap:: attrib::) "int *alist = Scm_ListToGdkGLAttribList(attrib); SCM_RETURN(SCM_MAKE_GDK_GL_PIXMAP(gdk_gl_pixmap_new(glconfig, pixmap, alist)));") (define-cproc gdk-gl-pixmap-get-pixmap (glpixmap::) (call "gdk_gl_pixmap_get_pixmap")) (define-cproc gdk-pixmap-set-gl-capability (pixmap:: glconfig:: attrib::) "int *alist = Scm_ListToGdkGLAttribList(attrib); SCM_RETURN(SCM_MAKE_GDK_GL_PIXMAP(gdk_pixmap_set_gl_capability(pixmap, glconfig,alist)));") (define-cproc gdk-pixmap-usnet-gl-capability (pixmap::) (call "gdk_pixmap_unset_gl_capability")) (define-cproc gdk-pixmap-is-gl-capable (pixmap::) (call "gdk_pixmap_is_gl_capable")) (define-cproc gdk-pixmap_get_gl_pixmap (pixmap::) (call "gdk_pixmap_get_gl_pixmap")) (define-cproc gdk-pixmap_get_gl_drawable (pixmap::) (call "gdk_pixmap_get_gl_drawable")) ;;================================================================= ;; gdkglquery.h ;; (define-cproc gdk-gl-query-extension () (call "gdk_gl_query_extension")) (define-cproc gdk-gl-query-version () "int major = 0, minor = 0; gboolean r = gdk_gl_query_version(&major, &minor); SCM_RETURN(Scm_Values3(SCM_MAKE_BOOL(r), SCM_MAKE_INT(major), SCM_MAKE_INT(minor)));") (define-cproc gdk-gl-query-gl-extension (extension::) (call "gdk_gl_query_gl_extension")) ;;================================================================= ;; gdkgltokens.h ;; ;; Success return value (define-enum GDK_GL_SUCCESS ) ;; Attribute list terminator (define-enum GDK_GL_ATTRIB_LIST_NONE ) ;; Config Attributes (define-enum GDK_GL_USE_GL ) (define-enum GDK_GL_BUFFER_SIZE ) (define-enum GDK_GL_LEVEL ) (define-enum GDK_GL_RGBA ) (define-enum GDK_GL_DOUBLEBUFFER ) (define-enum GDK_GL_STEREO ) (define-enum GDK_GL_AUX_BUFFERS ) (define-enum GDK_GL_RED_SIZE ) (define-enum GDK_GL_GREEN_SIZE ) (define-enum GDK_GL_BLUE_SIZE ) (define-enum GDK_GL_ALPHA_SIZE ) (define-enum GDK_GL_DEPTH_SIZE ) (define-enum GDK_GL_STENCIL_SIZE ) (define-enum GDK_GL_ACCUM_RED_SIZE ) (define-enum GDK_GL_ACCUM_GREEN_SIZE ) (define-enum GDK_GL_ACCUM_BLUE_SIZE ) (define-enum GDK_GL_ACCUM_ALPHA_SIZE ) (define-enum GDK_GL_X_VISUAL_TYPE ) (define-enum GDK_GL_CONFIG_CAVEAT ) (define-enum GDK_GL_TRANSPARENT_TYPE ) (define-enum GDK_GL_TRANSPARENT_INDEX_VALUE ) (define-enum GDK_GL_TRANSPARENT_RED_VALUE ) (define-enum GDK_GL_TRANSPARENT_GREEN_VALUE ) (define-enum GDK_GL_TRANSPARENT_BLUE_VALUE ) (define-enum GDK_GL_TRANSPARENT_ALPHA_VALUE ) (define-enum GDK_GL_DRAWABLE_TYPE ) (define-enum GDK_GL_RENDER_TYPE ) (define-enum GDK_GL_X_RENDERABLE ) (define-enum GDK_GL_FBCONFIG_ID ) (define-enum GDK_GL_MAX_PBUFFER_WIDTH ) (define-enum GDK_GL_MAX_PBUFFER_HEIGHT ) (define-enum GDK_GL_MAX_PBUFFER_PIXELS ) (define-enum GDK_GL_VISUAL_ID ) (define-enum GDK_GL_SAMPLE_BUFFERS ) (define-enum GDK_GL_SAMPLES ) ;; Error return values from get-config. (define-enum GDK_GL_BAD_SCREEN ) (define-enum GDK_GL_BAD_ATTRIBUTE ) (define-enum GDK_GL_NO_EXTENSION ) (define-enum GDK_GL_BAD_VISUAL ) (define-enum GDK_GL_BAD_CONTEXT ) (define-enum GDK_GL_BAD_VALUE ) (define-enum GDK_GL_BAD_ENUM ) ;; FBConfig attribute values (define-enum GDK_GL_DONT_CARE ) (define-enum GDK_GL_RGBA_BIT ) (define-enum GDK_GL_COLOR_INDEX_BIT ) (define-enum GDK_GL_WINDOW_BIT ) (define-enum GDK_GL_PIXMAP_BIT ) (define-enum GDK_GL_PBUFFER_BIT ) (define-enum GDK_GL_NONE ) (define-enum GDK_GL_SLOW_CONFIG ) (define-enum GDK_GL_NON_CONFORMANT_CONFIG ) (define-enum GDK_GL_TRUE_COLOR ) (define-enum GDK_GL_DIRECT_COLOR ) (define-enum GDK_GL_PSEUDO_COLOR ) (define-enum GDK_GL_STATIC_COLOR ) (define-enum GDK_GL_GRAY_SCALE ) (define-enum GDK_GL_STATIC_GRAY ) (define-enum GDK_GL_TRANSPARENT_RGB ) (define-enum GDK_GL_TRANSPARENT_INDEX ) (define-enum GDK_GL_PRESERVED_CONTENTS ) (define-enum GDK_GL_LARGEST_PBUFFER ) (define-enum GDK_GL_PBUFFER_HEIGHT ) (define-enum GDK_GL_PBUFFER_WIDTH ) (define-enum GDK_GL_WIDTH ) (define-enum GDK_GL_HEIGHT ) (define-enum GDK_GL_EVENT_MASK ) (define-enum GDK_GL_RGBA_TYPE ) (define-enum GDK_GL_COLOR_INDEX_TYPE ) (define-enum GDK_GL_SCREEN ) (define-enum GDK_GL_PBUFFER_CLOBBER_MASK ) (define-enum GDK_GL_DAMAGED ) (define-enum GDK_GL_SAVED ) (define-enum GDK_GL_WINDOW ) (define-enum GDK_GL_PBUFFER ) (define-enum GDK_GL_FRONT_LEFT_BUFFER_BIT ) (define-enum GDK_GL_FRONT_RIGHT_BUFFER_BIT ) (define-enum GDK_GL_BACK_LEFT_BUFFER_BIT ) (define-enum GDK_GL_BACK_RIGHT_BUFFER_BIT ) (define-enum GDK_GL_AUX_BUFFERS_BIT ) (define-enum GDK_GL_DEPTH_BUFFER_BIT ) (define-enum GDK_GL_STENCIL_BUFFER_BIT ) (define-enum GDK_GL_ACCUM_BUFFER_BIT ) ;(define-enum GDK_GL_X_VISUAL_TYPE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_TYPE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_INDEX_VALUE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_RED_VALUE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_GREEN_VALUE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_BLUE_VALUE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_ALPHA_VALUE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRUE_COLOR_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_DIRECT_COLOR_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_PSEUDO_COLOR_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_STATIC_COLOR_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_GRAY_SCALE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_STATIC_GRAY_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_NONE_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_RGB_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_TRANSPARENT_INDEX_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_VISUAL_CAVEAT_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_SLOW_VISUAL_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_NON_CONFORMANT_VISUAL_EXT );removed @ gtkglext0.7 ;; for get-cilent-string ;(define-enum GDK_GL_VENDOR );removed @ gtkglext0.7 ;(define-enum GDK_GL_VERSION );removed @ gtkglext0.7 ;(define-enum GDK_GL_EXTENSIONS );removed @ gtkglext0.7 ;(define-enum GDK_GL_SHARE_CONTEXT_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_VISUAL_ID_EXT );removed @ gtkglext0.7 ;(define-enum GDK_GL_SCREEN_EXT );removed @ gtkglext0.7 ;;================================================================= ;; gdkglversion.h ;; (define-cproc gdk-gl-ext-check-version (major:: minor:: micor::) (call "GDKGLEXT_CHECK_VERSION")) ;;================================================================= ;; gdkglwindow.h ;; (define-cclass "GdkGLWindow*" "Scm_GdkGLWindowClass" ("Scm_GdkGLDrawableClass" "Scm_GObjectClass") (;;(glconfig :type :setter #f);removed @ gtkglext0.7 (drawable :type :setter #f)) ) (initcode "Scm_GtkRegisterClass(GDK_TYPE_GL_WINDOW, SCM_CLASS_GDK_GL_WINDOW);") (define-cproc gdk-gl-window-new (glconfig:: window:: attrib::) "int *alist = Scm_ListToGdkGLAttribList(attrib); SCM_RETURN(SCM_MAKE_GDK_GL_WINDOW(gdk_gl_window_new(glconfig, window, alist)));") (define-cproc gdk-gl-window-get-window (glwindow::) (call "gdk_gl_window_get_window")) (define-cproc gdk-window-set-gl-capability (window:: glconfig:: attrib::) "int *alist = Scm_ListToGdkGLAttribList(attrib); SCM_RETURN(SCM_MAKE_GDK_GL_WINDOW(gdk_window_set_gl_capability(window, glconfig,alist)));") (define-cproc gdk-window-usnet-gl-capability (window::) (call "gdk_window_unset_gl_capability")) (define-cproc gdk-window-is-gl-capable (window::) (call "gdk_window_is_gl_capable")) (define-cproc gdk-window-get-gl-window (window::) (call "gdk_window_get_gl_window")) (define-cproc gdk-window-get-gl-drawable (window::) (call "gdk_window_get_gl_drawable")) ;; Local variables: ;; mode: scheme ;; end: gauche-gtk-0.6+git20160927/gtkgl/gtkgl.types000066400000000000000000000037351300401456300203220ustar00rootroot00000000000000;;; ;;; gdkgllib.types - common type defs ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gtkgl.types,v 1.3 2007/01/13 01:36:30 maruska Exp $ ;;; (include "../src/gtk-lib.types") (define-type "GdkGLConfig*" #f "SCM_GDK_GL_CONFIG_P" "SCM_GDK_GL_CONFIG" "SCM_MAKE_GDK_GL_CONFIG") (define-type -or-null "GdkGLConfig*" #f "SCM_GDK_GL_CONFIG_OR_NULL_P" "SCM_GDK_GL_CONFIG" "SCM_MAKE_GDK_GL_CONFIG") (define-type "GdkGLContext*" #f "SCM_GDK_GL_CONTEXT_P" "SCM_GDK_GL_CONTEXT" "SCM_MAKE_GDK_GL_CONTEXT") (define-type -or-null "GdkGLContext*" #f "SCM_GDK_GL_CONTEXT_OR_NULL_P" "SCM_GDK_GL_CONTEXT" "SCM_MAKE_GDK_GL_CONTEXT") (define-type "GdkGLDrawable*" #f "SCM_GDK_GL_DRAWABLE_P" "SCM_GDK_GL_DRAWABLE" "SCM_MAKE_GDK_GL_DRAWABLE") (define-type -or-null "GdkGLDrawable*" #f "SCM_GDK_GL_DRAWABLE_OR_NULL_P" "SCM_GDK_GL_DRAWABLE" "SCM_MAKE_GDK_GL_DRAWABLE") (define-type "GdkGLPixmap*" #f "SCM_GDK_GL_PIXMAP_P" "SCM_GDK_GL_PIXMAP" "SCM_MAKE_GDK_GL_PIXMAP") (define-type -or-null "GdkGLPixmap*" #f "SCM_GDK_GL_PIXMAP_OR_NULL_P" "SCM_GDK_GL_PIXMAP" "SCM_MAKE_GDK_GL_PIXMAP") (define-type "GdkGLWindow*" #f "SCM_GDK_GL_WINDOW_P" "SCM_GDK_GL_WINDOW" "SCM_MAKE_GDK_GL_WINDOW") (define-type -or-null "GdkGLWindow*" #f "SCM_GDK_GL_WINDOW_OR_NULL_P" "SCM_GDK_GL_WINDOW" "SCM_MAKE_GDK_GL_WINDOW") ;; Local variables: ;; mode: scheme ;; end: gauche-gtk-0.6+git20160927/gtkgl/gtkgllib.stub000066400000000000000000000045751300401456300206250ustar00rootroot00000000000000;;; ;;; gtkgllib.stub ;;; ;;; Copyright(C) 2002-2003 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gtkgllib.stub,v 1.6 2007/08/22 17:06:38 maruska Exp $ ;;; ;; mmc: with Cgen, this must come first "#include \"gauche-gtkgl.h\"" (include "gtkgl.types") ;;================================================================= ;; gdkglversion.h ;; (define-cproc gtk-gl-ext-check-version (major:: minor:: micro::) (call "GDKGLEXT_CHECK_VERSION")) ;;================================================================= ;; gdkglwidget.h ;; (define-cproc gtk-widget-set-gl-capability (widget:: glconfig:: share-list::-or-null direct:: render-type::) (call "gtk_widget_set_gl_capability")) (define-cproc gtk-widget-is-gl-capable (widget::) (call "gtk_widget_is_gl_capable")) (define-cproc gtk-widget-get-gl-config (widget::) (call "gtk_widget_get_gl_config")) (if "GTKGLEXT_CHECK_VERSION(0, 7, 0)" (define-cproc gtk-widget-create-gl-context (widget:: share-list::-or-null direct:: render-type::) (call "gtk_widget_create_gl_context")) ) (define-cproc gtk-widget-get-gl-context (widget::) (call "gtk_widget_get_gl_context")) (define-cproc gtk-widget-get-gl-window (widget::) (call "gtk_widget_get_gl_window")) (define-cproc gtk-widget-get-gl-drawable (widget::) (call "gtk_widget_get_gl_drawable")) ;; Local variables: ;; mode: scheme ;; end: gauche-gtk-0.6+git20160927/gtkgl/test.scm000066400000000000000000000001211300401456300175710ustar00rootroot00000000000000(use gauche.test) (test-start "GtkGLExt") (use gtk) (use gtk.gtkgl) (test-end) gauche-gtk-0.6+git20160927/install-sh000077500000000000000000000127361300401456300170210ustar00rootroot00000000000000#!/bin/sh # # install - install a program, script, or datafile # This comes from X11R5 (mit/util/scripts/install.sh). # # Copyright 1991 by the Massachusetts Institute of Technology # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation, and that the name of M.I.T. not be used in advertising or # publicity pertaining to distribution of the software without specific, # written prior permission. M.I.T. makes no representations about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. It can only install one file at a time, a restriction # shared with many OS's install programs. # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" mkdirprog="${MKDIRPROG-mkdir}" transformbasename="" transform_arg="" instcmd="$mvprog" chmodcmd="$chmodprog 0755" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" dir_arg="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -d) dir_arg=true shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; -t=*) transformarg=`echo $1 | sed 's/-t=//'` shift continue;; -b=*) transformbasename=`echo $1 | sed 's/-b=//'` shift continue;; *) if [ x"$src" = x ] then src=$1 else # this colon is to work around a 386BSD /bin/sh bug : dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 else true fi if [ x"$dir_arg" != x ]; then dst=$src src="" if [ -d $dst ]; then instcmd=: chmodcmd="" else instcmd=mkdir fi else # Waiting for this to be detected by the "$instcmd $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if [ -f $src -o -d $src ] then true else echo "install: $src does not exist" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 else true fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` else true fi fi ## this sed command emulates the dirname command dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` # Make sure that the destination directory exists. # this part is taken from Noah Friedman's mkinstalldirs script # Skip lots of stat calls in the usual case. if [ ! -d "$dstdir" ]; then defaultIFS=' ' IFS="${IFS-${defaultIFS}}" oIFS="${IFS}" # Some sh's can't handle IFS=/ for some reason. IFS='%' set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` IFS="${oIFS}" pathcomp='' while [ $# -ne 0 ] ; do pathcomp="${pathcomp}${1}" shift if [ ! -d "${pathcomp}" ] ; then $mkdirprog "${pathcomp}" else true fi pathcomp="${pathcomp}/" done fi if [ x"$dir_arg" != x ] then $doit $instcmd $dst && if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi else # If we're going to rename the final executable, determine the name now. if [ x"$transformarg" = x ] then dstfile=`basename $dst` else dstfile=`basename $dst $transformbasename | sed $transformarg`$transformbasename fi # don't allow the sed command to completely eliminate the filename if [ x"$dstfile" = x ] then dstfile=`basename $dst` else true fi # Make a temp file name in the proper directory. dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp && trap "rm -f ${dsttmp}" 0 && # and set any options; do chmod last to preserve setuid bits # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $instcmd $src $dsttmp" command. if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && # Now rename the file to the real destination. $doit $rmcmd -f $dstdir/$dstfile && $doit $mvcmd $dsttmp $dstdir/$dstfile fi && exit 0 gauche-gtk-0.6+git20160927/lib/000077500000000000000000000000001300401456300155525ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/lib/Makefile.in000066400000000000000000000023421300401456300176200ustar00rootroot00000000000000.PHONY: test clean install SHELL = @SHELL@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ datarootdir = @datarootdir@ srcdir = @srcdir@ VPATH = $(srcdir) top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ GOSH = @GOSH@ GAUCHE_CONFIG = @GAUCHE_CONFIG@ INSTALL = @GAUCHE_INSTALL@ DESTDIR = GAUCHE_PKGINCDIR = $(DESTDIR)@GAUCHE_PKGINCDIR@ GAUCHE_PKGLIBDIR = $(DESTDIR)@GAUCHE_PKGLIBDIR@ GAUCHE_PKGARCHDIR = $(DESTDIR)@GAUCHE_PKGARCHDIR@ SCMFILES = gtk.scm gtk/gtkaux.scm gtk/gdkkeysyms.scm gtk/listener.scm \ gtk/error-dialog.scm \ h2s/emit.scm h2s/fixup.scm h2s/gtk-types-for-emit.scm \ h2s/gtk-types-for-fixup.scm h2s/gtk-types.scm h2s/lookup.scm \ h2s/objects.scm h2s/parse.scm h2s/program.scm h2s/top.scm \ h2s/track.scm h2s/utils.scm CONFIG_GENERATED = Makefile all : gtk/gdkkeysyms.scm gtk/gdkkeysyms.scm : gen-keysyms.scm $(GOSH) ./gen-keysyms.scm check : install : $(INSTALL) -m 444 -T $(GAUCHE_PKGLIBDIR) $(SCMFILES) clean : rm -rf core *~ gtk/*~ gtk/gdkkeysyms.scm h2s/*~ distclean : clean rm -rf $(CONFIG_GENERATED) maintainer-clean : clean rm -rf $(CONFIG_GENERATED) gauche-gtk-0.6+git20160927/lib/gen-keysyms.scm000066400000000000000000000014631300401456300205350ustar00rootroot00000000000000;; ;; Generates gdk/gdkkeysyms.scm from gdk/gdkkeysyms.h ;; (use gauche.process) (use srfi-13) (define (main args) (let1 prefix (process-output->string "pkg-config --variable=prefix gtk+-2.0") (when (string-null? prefix) (error "can't get the gtk+-2.0 install location. pkg-config problem?")) (with-output-to-file "gtk/gdkkeysyms.scm" (lambda () (print ";; Automatically generated") (print "(select-module gtk)") (with-input-from-file #`",|prefix|/include/gtk-2.0/gdk/gdkkeysyms.h" (cut port-for-each filter read-line)) (print "(provide \"gtk/gdkkeysyms\")")))) 0) (define (filter line) (rxmatch-if (rxmatch #/^#define\s+([\w_]+)\s+0x([\w]+)/ line) (#f name value) (print #`"(define-constant ,|name| #x,|value|)") #f)) gauche-gtk-0.6+git20160927/lib/gtk.scm000066400000000000000000000025561300401456300170530ustar00rootroot00000000000000;;; ;;; gtk.scm - Gauche GTk binding ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gtk.scm,v 1.9 2007/01/13 01:36:31 maruska Exp $ ;;; (define-module gtk (export-all) (use srfi-4) (use gauche.parameter) (use gauche.charconv) ) (select-module gtk) ;; Invoke callback. Called from Scm_GClosureMarshal ;; TODO: We don't want to export these. (define (%gtk-call-callback proc args) (with-error-handler (^[exc] ((gtk-callback-error-handler) exc)) (^[] (apply proc args)))) (define gtk-callback-error-handler (make-parameter report-error)) (dynamic-load "gauche-gtk" :export-symbols #t) (require "gtk/gtkaux") (require "gtk/gdkkeysyms") (autoload "gtk/listener" gtk-scheme-listener-add) (define gpointer-mapping (make-hash-table 'string=?)) ;; mapping "signal-name" -> ( ( index . type) ....) ;; todo: C part depends on this, so it should be defined there! gauche-gtk-0.6+git20160927/lib/gtk/000077500000000000000000000000001300401456300163375ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/lib/gtk/error-dialog.scm000066400000000000000000000043441300401456300214360ustar00rootroot00000000000000;;; ;;; gtk/error-dialog.scm - reports error via GUI dialog ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: error-dialog.scm,v 1.3 2007/01/13 01:36:31 maruska Exp $ ;;; ;; this file is to be autoloaded. ;; makes an error to be reported using gtk dialog. (define-module gtk.error-dialog (use gauche.mop.singleton) (use gauche.threads) (use gtk) (export gtk-scheme-enable-error-dialog )) (select-module gtk.error-dialog) (define-class () ((widget) (label) (parent :init-keyword :parent :init-value #f) (flags :init-keyword :flags :init-value 0) )) (define-method initialize ((self ) initargs) (next-method) (let* ([dialog (gtk-dialog-new-with-buttons "Error" (ref self 'parent) (ref self 'flags) GTK_STOCK_OK GTK_RESPONSE_ACCEPT)] [vbox (ref dialog 'vbox)] [label (gtk-label-new "")]) (g-signal-connect dialog "response" (lambda _ (gtk-widget-hide-all dialog))) (gtk-box-pack-start vbox label #t #t 10) (slot-set! self 'widget dialog) (slot-set! self 'label label) )) (define (gtk-report-error exc) (let ([self (instance-of )] [mesg (if (is-a? exc ) #"*** ERROR: ~(ref exc 'message)" (x->string exc))]) (gtk-label-set-text (ref self 'label) mesg) (gtk-widget-show-all (ref self 'widget)))) (define (gtk-scheme-enable-error-dialog . maybe-parent) (make :parent (get-optional maybe-parent #f)) (gtk-callback-error-handler gtk-report-error)) gauche-gtk-0.6+git20160927/lib/gtk/glgd.scm000066400000000000000000000072261300401456300177670ustar00rootroot00000000000000;;; ;;; gtk/glgd.scm - openGL Graph Display binding ;;; ;;; Copyright(C) 2004 by Shawn Taras (shawn_t@cementedminds.com) ;;; Copyright(C) 2004 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: glgd.scm,v 1.5 2007/01/13 01:36:31 maruska Exp $ ;;; (define-module gtk.glgd (use gl) (use gtk) (use gtk.gtkgl) (export-all)) (select-module gtk.glgd) (dynamic-load "gauche-glgd" :export-symbols #t) ;; Higher-level utilities ;; Class ;; Binds glgd-graph and gtk-drawing-area conveniently. (define-class () ((glconfig :init-keyword :glconfig :init-form (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH GDK_GL_MODE_DOUBLE)) (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB GDK_GL_MODE_DEPTH)) (error "Required visual not supported"))) (graph :init-keyword :graph :init-form (glgd-graph-create)) ;; temporary (connected :init-value #f) )) (define-method initialize ((self ) initargs) (next-method) ;; Set OpenGL-capability to the widget. (gtk-widget-set-gl-capability self (ref self 'glconfig) #f #t GDK_GL_RGBA_TYPE) ;; Initial event mask. (gtk-widget-set-events self (logior GDK_EXPOSURE_MASK GDK_VISIBILITY_NOTIFY_MASK)) ;; Default event handlings (g-signal-connect self "destroy" (^[w . _] (glgd-graph-fini (ref self 'graph)))) (g-signal-connect self "realize" (^[w . _] (with-gtkgl-context self gtk-graph-area-initialize))) (g-signal-connect self "configure_event" (^[w . _] (with-gtkgl-context self gtk-graph-area-configure))) (g-signal-connect self "expose_event" (^[w . _] (with-gtkgl-context self gtk-graph-area-draw))) (g-signal-connect self "map_event" (^[w . _] (with-gtkgl-context self gtk-graph-area-mapped))) ) (define-method gtk-graph-area-initialize ((self ) gldrawable glcontext) (gl-enable GL_DEPTH_TEST)) (define-method gtk-graph-area-configure ((self ) gldrawable glcontext) (let1 wsize (ref self 'allocation) (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height)) #t)) (define-method gtk-graph-area-draw ((self ) gldrawable glcontext) (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT)) (glgd-graph-draw (ref self 'graph)) (if (gdk-gl-drawable-is-double-buffered gldrawable) (gdk-gl-drawable-swap-buffers gldrawable) (gl-flush))) (define-method gtk-graph-area-mapped ((self ) gldrawable glcontext) (unless (and (ref self 'graph) (ref self 'connected)) (glgd-graph-connect (ref self 'graph) self) (set! (ref self 'connected) #t)) (gtk-widget-queue-draw self) #t) gauche-gtk-0.6+git20160927/lib/gtk/gtkaux.scm000066400000000000000000000037701300401456300203550ustar00rootroot00000000000000;;; ;;; gtk/gtkaux.scm - Auxiliary defs ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gtkaux.scm,v 1.4 2007/01/13 01:36:31 maruska Exp $ ;;; (select-module gtk) ;; GtkListStore -------------------------------------- (define (gtk-list-store-set list-store iter . args) (check-arg (cut is-a? <> ) list-store) (check-arg (cut is-a? <> ) iter) (unless (even? (length args)) (error "even number of arguments required, but got" args)) (let loop ((args args)) (unless (null? args) (gtk-list-store-set-value list-store iter (car args) (cadr args)) (loop (cddr args))))) ;; GtkTreeViewColumn --------------------------------- (define (gtk-tree-view-column-new-with-attributes title renderer . args) (check-arg string? title) (check-arg (cut is-a? <> ) renderer) (unless (even? (length args)) (error "cell renderer option arguments must be even number")) (let1 column (gtk-tree-view-column-new) (gtk-tree-view-column-set-title column title) (gtk-tree-view-column-pack-start column renderer #t) (let loop ((args args)) (unless (null? args) (gtk-tree-view-column-add-attribute column renderer (car args) (cadr args)) (loop (cddr args)))) column) ) ;; GtkTreeSelection ----------------------------------- (define (gtk-tree-selection-get-selected-multi selection) (let ((sels '())) (gtk-tree-selection-selected-foreach selection (lambda (model path iter) (push! sels iter))) (reverse sels))) gauche-gtk-0.6+git20160927/lib/gtk/gtkgl.scm000066400000000000000000000021241300401456300201520ustar00rootroot00000000000000;;; ;;; gtk/gtkgl.scm - GtkGLExt binding ;;; ;;; Copyright(C) 2002,2004 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gtkgl.scm,v 1.3 2007/01/13 01:36:31 maruska Exp $ ;;; (define-module gtk.gtkgl (use gtk) (export-all)) (select-module gtk.gtkgl) (dynamic-load "gauche-gtkgl" :export-symbols #t) ;; Higher-level utilities (define (with-gtkgl-context widget proc) (let ((gldrawable (gtk-widget-get-gl-drawable widget)) (glcontext (gtk-widget-get-gl-context widget))) (when (gdk-gl-drawable-gl-begin gldrawable glcontext) (proc widget gldrawable glcontext) (gdk-gl-drawable-gl-end gldrawable)))) gauche-gtk-0.6+git20160927/lib/gtk/listener.scm000066400000000000000000000030241300401456300206670ustar00rootroot00000000000000;;; ;;; gtk/listener.scm - Listener ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: listener.scm,v 1.5 2007/01/13 01:36:31 maruska Exp $ ;;; ;; this file is to be autoloaded (select-module gtk) (use gauche.listener) (define (gtk-scheme-listener-add . opts) (let* ((iport (get-keyword :input-port opts (current-input-port))) (prompter (get-keyword :prompter opts (lambda () (display "gosh-gtk> ")))) (id #f) (user-finalizer (get-keyword :finalizer opts values)) (listener (apply make :finalizer (lambda () (gtk-input-remove id) (user-finalizer)) :prompter prompter opts)) (handler (listener-read-handler listener))) (set! (port-buffering iport) :none) (set! id (gtk-input-add iport GDK_INPUT_READ (lambda (port flags) (handler)))) (listener-show-prompt listener))) gauche-gtk-0.6+git20160927/lib/h2s/000077500000000000000000000000001300401456300162465ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/lib/h2s/emit.scm000066400000000000000000000533751300401456300177250ustar00rootroot00000000000000 ;; what it wants from types and struct/enum/array ;; struct: ;; definition: i think i simply include the whole .types file! ;; scm-class-name-of c-type-of c-name-of ;; c-predicate-of c-unboxer-of c-boxer-of ;; only for `defined' ;; c-predicate-nullable-of ;; allocation-type-of ;; emit.stub-class-hierarchy ;; cpl-of ;; emit.h .... i already have it. (define-module h2s.emit (export emit-all) (use h2s.objects) (use h2s.gtk-types-for-emit) (use h2s.utils) (use h2s.track) (use text.tr) (use file.util) (use srfi-13) (use srfi-1) (use srfi-2) (use util.toposort) ) (select-module h2s.emit) (define debug #f) ;;================================================================ ;; PASS 3 - EMITTER ;; ;; emit.types - generate *.types file ;; emit.h - generate *.h file ;; emit.stub - generate *.stub file (define-method emit.types ((self ) commenter) (print #`"(define-type ,(scm-class-name-of self) \",(c-name-of (c-type-of self))\" #f") (print #`" \",(c-predicate-of self)\" \",(c-unboxer-of self)\" \",(c-boxer-of self)\")") ;; when do we use this one? ;; mmc: does this mean that every unboxer must handle the NULL case? (print #`"(define-type ,(scm-class-name-of self)-or-null \",(c-name-of (c-type-of self))\" #f") (print #`" \",(c-predicate-nullable-of self)\" \",(c-unboxer-of self)\" \",(c-boxer-of self)\")") (print)) ;; example of this? ....types in .hint files? How is that distributed/assigned to files? heh, (input-file "gtkcelllayout.h") is the parameter!!!! (define-method emit.types ((self ) commenter) (when (type? self) (print-body self))) ;; where is this produced ?? ;; (define-type "PangoAttrList*" #f #f #f "SCM_MAKE_PANGO_ATTR_LIST") ;; (define-type "PangoContext*" #f #f #f "SCM_MAKE_PANGO_CONTEXT") ;; this is my manual stuff !! ;; (define-type "gchar **" "list of C strings, free-d by the external library" "SCM_STRING_LIST_P" "SCM_STRING_LIST" "SCM_MAKE_STRING_LIST") (define-method emit.types ((self ) commenter) #f) ; what is ?? ;; this means, that functions don't produce text! ;; Q: where is the inheritance defined ? mm: i would expect in the (define-cclass `emit.stub-class-hierarchy' (define-method emit.h ((self ) commenter) (let1 atype (allocation-type-of self) ;; Structure definition. Note necessary for GObjects. (case atype ((refcounted indirect simple) (print #`"typedef struct Scm,(c-name-of self)Rec {") (print #`" SCM_HEADER;") (print #`" ,(c-name-of self) ,(if (eq? atype 'simple) \"\" \"*\")data;") (print #`"} Scm,(c-name-of self);") (print))) ;; Class declaration (print #`"SCM_CLASS_DECL(Scm_,(c-name-of self)Class);") (print #`"#define ,(c-class-macro-of self) (&Scm_,(c-name-of self)Class)") ;; Type predicate (case atype ((gobject) (print #`"#define ,(c-predicate-of self)(obj) (Scm_TypeP(obj, ,(c-class-macro-of self)))")) ; walk the gauche inheritance tree (else ;; mmc: SCM_GTK_SOURCE_BUFFER is not a gobject ??? gtk says it is. GtkTextBuffer -> (print #`"#define ,(c-predicate-of self)(obj) SCM_XTYPEP(obj, ,(c-class-macro-of self))"))) ;; Boxer and unboxer (case atype ((gobject) ;; mmc: dynamic typing? (print #`"#define ,(c-unboxer-of self)(obj) SCM_GOBJECT_UNBOX(,(c-caster-of self), obj)") (print #`"#define ,(c-boxer-of self)(obj) SCM_GOBJECT_BOX(obj)")); see: /usr/lib/gauche/0.8.2/include/gauche-gtk.h ((refcounted indirect) ;; mmc: examples of these^??? (print #`"#define ,(c-unboxer-of self)(obj) (SCM_FALSEP(obj)?NULL:((Scm,(c-name-of self)*)(obj))->data)") (print #`"#define ,(c-boxer-of self)(obj) (Scm_Make,(c-name-of self)(obj))")) (else ;; we don't want to segfault: if the object provides no way to ensure that it's not deallocated, we cannot provide a ;; "once a pointer to it". So we provide what we are sure about: the `data' slot. ;; even worse? V sort-of inline: the `data' slot itself is the value. (print #`"#define ,(c-unboxer-of self)(obj) (SCM_FALSEP(obj)?NULL:&((Scm,(c-name-of self)*)(obj))->data)") (print #`"#define ,(c-boxer-of self)(obj) (Scm_Make,(c-name-of self)(obj))"))) ;; (print #`"#define ,(c-predicate-nullable-of self)(obj) (SCM_FALSEP(obj)||,(c-predicate-of self)(obj))") ;;; why is Gobject excluded? ;; b/c we have SCM_GOBJECT_BOX ? (case atype ((refcounted indirect simple) ; ???? rest is what? ;; mmc:cannot all these be the same function? (w/o C type-checking) (print #`"extern ScmObj Scm_Make,(c-name-of self)(,(c-name-of self) *data);"))) (print))) (define-method emit.h ((self ) commenter) #f) (define-method emit.stub ((self ) commenter) (print (commenter #`" struct ,(c-name-of self)")) (print) (unless (internal? self) ; once again: when? functions _ref _unref _get_type. But structs ?? ; `disable-cclass' in the hints file! (case (allocation-type-of self) ((gobject) (emit.stub-gobject self commenter)) ((indirect) (emit.stub-indirect self commenter)) ; again: what is `indirect'? just pointer at a memory! ((refcounted) (emit.stub-refcounted self commenter)) (else (emit.stub-simple self commenter))))) ;; self is a object. (define (emit.stub-gobject self commenter) (print #`"(define-cclass ,(scm-class-name-of self) :,(qualifier-of self)") ; (define-cclass :base (print #`" \"ScmGObject*\" \"Scm_,(c-name-of self)Class\"") (emit.stub-class-hierarchy self) ;; Exclude the first slot which is an instance of superclass (let1 fields (fields-of self) (if (null? fields) (emit.stub-fields '()) (emit.stub-fields (cdr fields)))) ;; Allocator (print #`"(allocator (c \"Scm_GtkObjectAllocate\"))") ; ;; for when i want to create an object in scheme: calling (make where klass is a subclass(!) of a gtk one. ;; /p/gauche-gtk-0.4.1/work/Gauche-gtk-0.4.1/src/gauche-gtk.c ;; mmc: what is this parameter to `define-cclass' ? This is only for Multiple-Inheritance! (otherwise (first cpi)) ;; Direct supers, if it has mixin (when (not (null? (direct-supers-of self))) (write (cons 'direct-supers (direct-supers-of self))) (newline)) (print #`" )") (print) ;; Register initialization code (print #`"(initcode \"Scm_GtkRegisterClass(,(gtk-type-name-of self), ,(c-class-macro-of self));\n\")") ;; why is this needed? why don't i use initcode in my hand-written .stub files? (print)) ;; it's all pieces of C embedded ! (define (emit.stub-refcounted self commenter) (let ((finalizer #`"scm_,(c-name-of self)_finalize") (cfn (string-tr (mixed-case-name->hyphenated-name (x->string (c-name-of self))) "-" "_"))) (print #`"\"static void ,|finalizer|(ScmObj obj, void* data)") (print #`" {") (print #`" Scm,(c-name-of self) *p = (Scm,(c-name-of self)*)obj;") (print #`" ,(c-name-of self) *d = ,(c-unboxer-of self)(obj);") (print #`" ,|cfn|_unref(d);") (print #`" p->data = NULL;") (print #`" }\"") (print) (print #`"\"ScmObj Scm_Make,(c-name-of self)(,(c-name-of self) *data)") (print #`" {") (print #`" Scm,(c-name-of self) *z = SCM_NEW(Scm,(c-name-of self));") (print #`" SCM_SET_CLASS(z, ,(c-class-macro-of self));") (print #`" z->data = data;") (print #`" Scm_RegisterFinalizer(SCM_OBJ(z), ,|finalizer|, NULL);") (print #`" ,|cfn|_ref(z->data);") (print #`" return SCM_OBJ(z);") (print #`" }\"") (print) (print #`"(define-cclass ,(scm-class-name-of self)") (print #`" \",(c-name-of self)*\" \"Scm_,(c-name-of self)Class\"") (emit.stub-class-hierarchy self) (emit.stub-fields (fields-of self)) (print #`" )") (print))) (define (emit.stub-indirect self commenter) (let ((finalizer #`"scm_,(c-name-of self)_finalize")) (when (c-free-proc-of self) (print #`"\"static void ,|finalizer|(ScmObj obj, void* data)") (print #`" {") (print #`" Scm,(c-name-of self) *p = (Scm,(c-name-of self)*)obj;") (print #`" ,(c-name-of self) *d = ,(c-unboxer-of self)(obj);") (print #`" ,(c-free-proc-of self)(d);") (print #`" p->data = NULL;") (print #`" }\"") (print)) (print #`"\"ScmObj Scm_Make,(c-name-of self)(,(c-name-of self) *data)") (print #`" {") (print #`" Scm,(c-name-of self) *z = SCM_NEW(Scm,(c-name-of self));") (print #`" SCM_SET_CLASS(z, ,(c-class-macro-of self));") (if (c-copy-proc-of self) (print #`" z->data = ,(c-copy-proc-of self)(data);") (print #`" z->data = data;")) (when (c-free-proc-of self) (print #`" Scm_RegisterFinalizer(SCM_OBJ(z), ,|finalizer|, NULL);")) (print #`" return SCM_OBJ(z);") (print #`" }") (print #`"\"") (print) (print #`"(define-cclass ,(scm-class-name-of self)") (print #`" \",(c-name-of self)*\" \"Scm_,(c-name-of self)Class\"") (emit.stub-class-hierarchy self) (emit.stub-fields (fields-of self)) ;; What if we provide a printer!? (when (slot-bound? self 'printer) (print "(printer") (write (slot-ref self 'printer)) (print ")")) (print #`" )") (print))) (define (emit.stub-simple self commenter) (print #`"\"ScmObj Scm_Make,(c-name-of self)(,(c-name-of self) *data)") (print #`" {") (cond ((allocator-of self) => print) ; (else (print #`" Scm,(c-name-of self) *z = SCM_NEW(Scm,(c-name-of self));") (print #`" SCM_SET_CLASS(z, ,(c-class-macro-of self));") (print #`" if (data) z->data = *data; /*copy*/") (print #`" return SCM_OBJ(z);"))) (print #`" }") (print #`"\"") (print) (print #`"(define-cclass ,(scm-class-name-of self)") (print #`" \",(c-name-of self)*\" \"Scm_,(c-name-of self)Class\"") (emit.stub-class-hierarchy self) (emit.stub-fields (fields-of self)) (print #`" (allocator \"return Scm_Make,(c-name-of self)(NULL);\")") (print #`" )") (print)) (define (emit.stub-class-hierarchy self) (format #t " ~s\n" (cpl-of self))) (define (emit.stub-fields fields) (print " (") (for-each emit.stub-field fields) (print " )")) (define (emit.stub-field field) (let ((sname (scm-name-of field)) (type (scm-type-of (type-of field)))) (if (accessible? field) (format #t " ~s\n" ; we are outputing the .stub: this is sexp! `(,sname ,@(if (not (pair? type)) (list :type type) ; the best option! '()) ,@(if (not (eq? (getter-of field) #t)) (list :getter (getter-of field)) ;; no getter! '()) ,@(if (not (eq? (setter-of field) #t)) (list :setter (setter-of field)) '()))) (begin ;(logformat-color 207 "field ~a not accessible!\n" sname) (print #`" ;; ,sname :type ,type"))))) (define-method emit.stub ((self ) commenter) (print (commenter #`" enum ,(c-name-of self)")) (for-each (lambda (v) (print #`"(define-enum ,v)")) (values-of self)) (print)) ;; (define-cproc gtk-entry-new () (return "gtk_entry_new")) (define-method emit.stub ((self ) commenter) (print (commenter (c-name-of self))) (unless (internal? self) (let* ((unknown-arg? #f) (s-name (scm-name-of self)) ;function! (args (map (lambda (arg) (cond ((null? arg) (error "huh?" (c-name-of self))) ((symbol? arg) arg) ; these come e.g. from fix-arguments! (in .hints files) (else (let ((name (c-name-of arg)) (s-type (scm-type-of (type-of arg)))) ;; scm-type-of is method of (or ) (when (pair? s-type) (if debug (logformat-color 'red "type ~a is unknown (~a)\n" (type-of arg) (scm-type-of (type-of arg)))) (set! unknown-arg? #t)) (string->symbol #`",|name|::,|s-type|"))))) (arguments-of self))) (ret (or (and-let* ((r (return-type-of self)) (t (scm-type-of r))) (when (pair? t) (set! unknown-arg? #t)) (list t)) '())) (sig `(define-cproc ,s-name ,args ,(or (body-of self) `(call ,@ret ,(x->string (c-name-of self))))))) (if unknown-arg? (begin ;(print "this is wrong, right?") (print (commenter sig))) ;mmc: wrong.... (begin (write sig) (newline)))) (print))) (define-method emit.stub ((self ) commenter) (unless (type? self) (print-body self))) (define (c-commenter content) #`"/* ,|content| */") ;(define (s-commenter content) #`";; ,content") (define (s-commenter content); #`";; ,content") (let1 content (if (string? content) content #`",content") (string-append ";; " (string-join (string-split content "\n") "\n;; ")))) (define (emitter method commenter) ;; mmc: fixme: (if (eq? commenter s-commenter) (print (commenter "-*-scheme-*-")) (print (commenter "-*-c-*-"))) (print (commenter "Automatically generated - DO NOT EDIT")) (print) (for-each-source-file (lambda (file defined) ;defined is the list of definitions (unless (string=? file "archive") ;fixme: this is the one i use for DB: can it be a #f ? (print (commenter (sys-basename file))) (print) (for-each (cut method <> commenter) defined))))) ;; Emit gtk-lib.inits ;; The order of initialization is important, since the superclasses have ;; to be initialized before initializing subclass. Sort-files-for-inits ;; takes care of it. (define (emit.inits init-function) (define (base file) (string-tr (string-drop-right (sys-basename file) 2) "-" "_")) (define files (sort-files-for-inits)) (if debug (logformat "emit.inits: ~a\n" files)) (print (c-commenter "-*-c-*-")) (print (c-commenter "Automatically generated - DO NOT EDIT")) (print) (for-each (lambda (file) (print #`"extern void Scm_Init_,(base file)(ScmModule*);")) files) (print) (print init-function) ;mmc ! fixed (print #`"{") (for-each (lambda (file) (print #`" Scm_Init_,(base file)(mod);")) files) (print #`"}")) ;; Sort files so that classes are initialized in the right order. (define (sort-files-for-inits) (let* ((files&defs (alist-delete "archive" (get-files&definitions))) ;; Quick mapper from to is defining file (struct->file (let ((table (make-hash-table))) (for-each (lambda (file&defs) (for-each (lambda (def) (when (is-a? def ) (hash-table-put! table def (car file&defs)))) (cdr file&defs))) files&defs) (lambda (struct) (hash-table-get table struct #f)))) ;; returns a file that defines supertype of the given struct, or #f. (get-super-file (lambda (src-file struct) (and-let* ((super (superclass-of struct)) ((is-a? (body-of super) )) (file (struct->file (body-of super))) ((not (equal? src-file file)))) file))) (dependency-table (let ((table (make-hash-table 'string=?))) (for-each (lambda (file&defs) (hash-table-put! table (car file&defs) '())) files&defs) (for-each (lambda (file&defs) (receive (file defs) (car+cdr file&defs) (for-each (lambda (def) (and-let* (((is-a? def )) (super (get-super-file file def)) ((not (member super (hash-table-get table file))))) (hash-table-push! table file super))) defs))) files&defs) table))) (if debug (logformat "sort-files-for-inits: ~a\n" files&defs)) (logformat "~s\n" (hash-table-map dependency-table cons)) (reverse (topological-sort (hash-table-map dependency-table cons))))) ;; mmc: i think these are added because they are defined below the .h files we scan. I.e. in glib. ;; ;; These types will be added to gtk-lib.types (define *predefined-types* '((define-type "const char *" #f "SCM_STRINGP" "CONST_CHAR_PTR") (define-type "const gchar *" #f "SCM_STRINGP" "CONST_GCHAR_PTR") (define-type "gchar *" #f "SCM_STRINGP" "CONST_GCHAR_PTR" "GCHAR_PTR_BOX") (define-type -or-null "const gchar *" #f "SCM_STRING_OR_NULL_P" "CONST_GCHAR_PTR_NULLABLE") (define-type "GObject *" #f "SCM_GOBJECT_P" "SCM_GOBJECT_OBJECT" "SCM_GOBJECT_BOX") (define-type "GTimer *" #f "SCM_GTIMER_P" "SCM_GTIMER" "SCM_MAKE_GTIMER") (define-type "GdkAtom" #f #f #f "SCM_MAKE_GDK_ATOM") (define-type "GdkEvent*" #f #f #f "SCM_MAKE_GDK_EVENT") (define-type "ScmGdkPointVector*") (define-type "ScmGdkSegmentVector*") (define-type "ScmGdkRectangleVector*") (define-type "ScmGdkColorVector*") (define-type "ScmGtkRadioGroup*") ;; we need a standard mechanism to incorporate these, really. (define-type "ScmU8Vector*") (define-type "ScmS8Vector*") (define-type "ScmU16Vector*") (define-type "ScmS16Vector*") (define-type "ScmU32Vector*") (define-type "ScmS32Vector*") (define-type "ScmU64Vector*") (define-type "ScmS64Vector*") (define-type "ScmF32Vector*") (define-type "ScmF64Vector*") )) ;; overwrite the original file iff it is changed; avoiding triggering ;; excessive make. (define (with-output-to-file-if-changed file thunk) (let1 tmpfile #`",|file|.tmp" (with-output-to-file tmpfile thunk) (if (and (file-exists? file) (file-equal? tmpfile file)) (begin (if debug (report #`" no change in ,file")) (sys-unlink tmpfile)) (begin (report #`" writing ,file") (sys-rename tmpfile file))))) (define (emit-all types-file central-header-file include-h-file init-function inits-file) ;; stub type definitions ;; This is to a common .types file, included by all .stubs. ;; It contains the (define-type ) sort-of opaque definition? `' (with-output-to-file-if-changed types-file (lambda () (emitter emit.types s-commenter) ;; some additional stuff (for-each (lambda (t) (write t) (newline)) *predefined-types*))) ;; i also need a central .h where i #include stuff (gauche.h) ... ;;central repository for generated types. (with-output-to-file-if-changed central-header-file (lambda () (emitter emit.h c-commenter))) ;; all these include that central type repo ^^^ b/c we don't track the .h files dependency, we define just all, in case... ;; (for-each-source-file (lambda (file defined) (unless (string=? file "archive") ;fixme: this is the one i use for DB: can it be a #f ? (receive (extra normal) (partition (cut is-a? <> ) defined) ;; (with-output-to-file-if-changed #`",(string-drop-right (sys-basename file) 2).stub" (lambda () (print (s-commenter "-*-scheme-*-")) (print (s-commenter "Automatically generated - DO NOT EDIT")) (print) ;; fixme! ;; this was original: (write `(include ,types-file)) ;(print #`"(include \",types-file\"") (unless (string=? types-file "gtk-lib.types") ;; include even this one: (print) (write `(include ,(string-append "/usr/lib/gauche/" (gauche-version) "/include/gtk-lib.types")))) ;fixme (print) ;; something which includes not only the central type repo. but also gauche specific .h files, and the .h file ;; which defines the macros used in our type repo!! gobject_unbox ... ;(for-each-reverse include-h-file (write #`"#include \",include-h-file\"") (print) (print) ;; need to emit first, for they may define ;; static fns. mmc: and? - C compiler want things defined _before_ used. (used in fix-body! ) (for-each (cut emit.stub <> s-commenter) extra) (for-each (cut emit.stub <> s-commenter) normal))))))) ;mmc: (with-output-to-file-if-changed inits-file (lambda () (emit.inits init-function)))) (provide "h2s/emit") gauche-gtk-0.6+git20160927/lib/h2s/fixup.scm000066400000000000000000000356011300401456300201120ustar00rootroot00000000000000 ;; functions to be used in the `fixup' stage: ;; to modify the gtk objects generated in the parser, ;; (define-module h2s.fixup (export fixup) (use h2s.gtk-types-for-fixup) (use h2s.utils) (use h2s.track) (use h2s.objects) (use srfi-13) (use srfi-2) (use srfi-1) (use text.tr) (use gauche.parameter) ) (select-module h2s.fixup) (define debug #f) ;;================================================================ ;; PASS 2 - FIXUPS ;; ;; Load "hints" files (define (load-hints hint-files) (parameterize ((input-file "hints.h")) ;;dummy (for-each (lambda (file) (when (file-exists? file) (report #`" loading ,file") (with-error-handler (lambda (e) (logformat "Error in ~a ~a:\n~a\n" file (input-file) (ref e 'message)) (sys-exit -1)) (lambda () (load file :environment (current-module)))))) ; eval as scheme! good. hint-files))) ;; utilities that can be used inside hints file (define-macro (define-cproc-fix name . body) `(cproc-fix ',name (lambda (self) ,@body))) (define (cproc-fix name body) (let1 self (or (find-function name) (make :scm-name name :c-name (string->symbol (string-tr (x->string name) "-" "_")) :return-type (find-type 'void) :arguments '())) (body self))) (define-macro (disable-cproc name) `(cond ((find-function ',name) => (lambda (f) (set! (internal? f) #t))))) (define-macro (fix-arguments! args) `(set! (arguments-of self) ,args)) (define-macro (fix-body! body) `(begin (set! (return-type-of self) #f) ;!!! (set! (body-of self) ,body))) (define-macro (define-cclass-fix name . body) `(cclass-fix ',name (lambda (self) ,@body))) (define (cclass-fix name body) (let1 self (or (find-struct name) (error "cclass-fix: no such struct" name)) (body self))) (define-macro (disable-cclass name) `(cond ((find-struct ',name) => (lambda (s) (set! (internal? s) #t))))) (define-macro (fix-field! name . body) `((lambda (field) . ,body) (or (find (lambda (p) (eq? (scm-name-of p) ,name)) (fields-of self)) (error "no such field" ',name)))) (define-macro (add-field! c-name typesig . opts) `(set! (fields-of self) (append (fields-of self) (make :c-name ,c-name :type (find-type-or-create ',typesig) ,@opts)))) ;; some field may be missing in certain gtk versions. ;; use this to ignore such fields. NB: there may be more than ;; one field registered, if such fields appears within union. (define-macro (ignore-field! name) `(for-each (lambda (f) (set! (accessible? f) #f)) (filter (lambda (p) (eq? (scm-name-of p) ,name)) (fields-of self)))) (define-macro (ignore-field-except! names) `(for-each (lambda (f) (set! (accessible? f) #f)) (remove (lambda (p) (memq (scm-name-of p) ,names)) (fields-of self)))) ;; mmc: So this macro is not hygienic, and it modifies the `self' variable! (define-macro (add-mixin! . c-mixin-names) ;; what if cpl-of fails? ;; `(begin (if (null? (cpl-of self)) (logformat "add-mixin! would fail on ~a\n" self) (set! (direct-supers-of self) (list ,@c-mixin-names (car (cpl-of self))))) (set! (cpl-of self) (list* ,@c-mixin-names (cpl-of self))))) ;; adds opaque GObject. ;; Fixme: This macro is used in the .hint files! To mark (define-macro (define-opaque c-name type) ; :indirect or :gobject `(make-opaque ',c-name ,type)) (define (make-opaque c-name type) (let* ((struct (make-struct #`"_,|c-name|" '()))) (case type ((:gobject) (set! (allocation-type-of struct) 'gobject) (set! (superclass-of struct) (find-type 'GObject)) ; fixme: GObject* ? (set! (cpl-of struct) '("Scm_GObjectClass"))) ((:indirect) (set! (allocation-type-of struct) 'indirect) (set! (superclass-of struct) #f) (set! (cpl-of struct) '())) ((:refcounted) (set! (allocation-type-of struct) 'refcounted) (set! (superclass-of struct) #f) (set! (cpl-of struct) '())) (else (error "unknown opaque object type" type))))) ;; mmc: haha!!! so this makes the .hints file a program! Compare w/ .stub files, which have partially(?) the _same_ syntax/commands! ;; extra cproc and cclass defined in the fix file is copied to ;; the output stub file. (define-macro (define-cclass . args) `(make :body '(define-cclass ,@args) :type? #f)) (define-macro (define-cproc . args) `(make :body '(define-cproc ,@args) :type? #f)) (define-macro (define-enum . args) `(make :body '(define-enum ,@args) :type? #f)) (define-macro (define-constant . args) `(make :body '(define-constant ,@args) :type? #f)) (define-macro (define-type . args) `(make :body '(define-type ,@args) :type? #t)) ; this is special! this goes to a different file! the central type repo. (define-macro (raw-code . args) `(make :body (string-join ',args "\n" 'suffix) :type? #f)) ;mmc: bug: \n is not ok. ;; figure out what implemenation type each structure is, ;; by examining its first field. ;; (define-method set-superclass ((self )) (if debug (logformat-color 118 "set-superclass: ~a\n" (c-name-of self))) (if (slot-bound? self 'superclass) (begin (if debug (logformat "we already know: ~a\n" (ref self 'superclass))) (superclass-of self)) ;; (receive (superclass gobject) (if (null? (fields-of self)) (values #f #f) (let ((first-slot-type (type-of (car (fields-of self))))) ;;<------ the specifics of the G-object inheritance system (cond ((memq (c-name-of first-slot-type) '(GObject GInitiallyUnowned)) ;;(eq? (c-name-of first-slot-type) 'GObject) ; `top' (logformat-color 111 "\tfirst-slot-type: ~a\n" first-slot-type) (values ;; mmc: fake: (was first-slot-type) (find-type 'GObject) #t)) ;; mmc: why do we look for the pointer-type ? ;; why do we want the pointer type?? .... b/c we have only those! ((and-let* ((ptrname (string->symbol #`",(c-name-of first-slot-type)*")) (ptrtype (find-type ptrname)) ;;mmc: todo! todo! todo! todo! todo! todo! todo! todo! todo! todo! todo! ((logformat "trying ~a\n" ptrtype)) ((is-a? (body-of ptrtype) )) ((set-superclass (body-of ptrtype)))) ; recurse!!! the structure? (if debug (logformat-color 51 "\t\tfound superclass: ~a: gobject? ~a\n" (c-name-of ptrtype) (gobject? (body-of ptrtype)))) (values ptrtype (gobject? (body-of ptrtype))))) ;and this is already determined ??? (else (logformat-color 10 "\t\t sorry: cannot find superclass of ~a\n" self) (values #f #f))))) ;; now we have (superclass gobject) ;; (when gobject (set! (allocation-type-of self) 'gobject)) ; do we do it in topological order ?? No: we recurse!!! (set! (superclass-of self) superclass) superclass))) (define-method set-cpl ((self )) (if debug (logformat-color 118 "set-cpl: ~a\n" (c-name-of self))) ;; after setting up superclass field of all structs, sets up CPL. ;; the hints file may modify CPL afterwards. (set! (cpl-of self) (let loop ((super (superclass-of self)) (classes '())) (logformat "set-cpl: ~a, cname: ~a\n" super (if super (c-name-of super) "#f")) (cond ((not super) (reverse classes)) ((eq? (c-name-of super) 'GObject) ; ugly hack! (reverse (cons "Scm_GObjectClass" classes))) ; ??? ((eq? (c-name-of super) 'GdkEvent*) (reverse (cons "Scm_GdkEventClass" classes))) (else (loop (superclass-of (body-of super)) (cons #`"Scm_,(c-name-of (body-of super))Class" classes))))))) ;; mmc: i would like an example of such data type/struct ;; i think the old gdk-pixbuf used such thing. (define-method set-refcounted ((self )) (if debug (logformat-color 118 "set-refcounted: ~a\n" (c-name-of self))) ;; use heuristics to find out if self is a ref-counting object (and not an ;; GObject). mmc: where do we avoid the GObject? (when (find (lambda (field) (equal? (c-name-of field) "ref_count")) (fields-of self)) ; it doesn't walk the inheritance tree ! (set! (allocation-type-of self) 'refcounted))) ;; the last step of fixup. i.e before fixup-functions, and before reading .hints! ;; (define-method set-fields ((self )) ;; scan 's in the fields and sets up it's default setter and getter (define (set-field-getter-n-setter field) (let ((stub-type (scm-type-of (type-of field)))) (cond ((eq? stub-type ') (set! (ref field 'getter) #`"return SCM_MAKE_STR_COPYING_SAFELY(obj->,(c-name-of field));") (set! (ref field 'setter) ;; Check if it is a string!!! #`"if (SCM_STRINGP(value)) {obj->,(c-name-of field) = Scm_GetString(SCM_STRING(value));};") ;Scm_GetStringConst(SCM_STRING(value)) fixme: this should use malloc, not GC_malloc_atomic! ) ;mmc! was #f mmc: what if it already has a value. Should i free it? fixme! ;; mmc: what is it? i would think it's symbol type -> ((not (pair? stub-type)) ; has proper stub type, so no need of g&s. ;; Basic types! etc. (if debug (logformat-color 213 "unknown type of the slot: ~a ~a\n" (c-name-of field) stub-type)) (set! (ref field 'getter) #t) (set! (ref field 'setter) #t)) ((and-let* ;; mmc: these don't even consider the scm-type!! ;; check if it is an embedded structure. ((ptrtype ;; we store as types pointers !!! This is scheme! (find-type (string->symbol #`",(c-name-of (type-of field))*"))) (ptrbody (body-of ptrtype)) ; can be symbol, struct, enum ... ;; why is this a condition ? What else ... symbol: char, int what's wrong w/ it? ((is-a? ptrbody ))) (set! (ref field 'getter) ;; getting the slot value and _immediately_ boxing it as the #`"return ,(c-boxer-of ptrbody)(&(obj->,(c-name-of field)));") (set! (ref field 'setter) #`"obj->,(c-name-of field) = *,(c-unboxer-of ptrbody)(value);") (logformat-color 214 "slot ~a embedded: ~a\n" (c-name-of field) (c-name-of ptrtype)) )) ( ;; check if it is an array reference. (and-let* ((arr (body-of (type-of field))) ((is-a? arr )) (elttype (element-type-of arr)) (unboxer (get-slot-boxer elttype))) (set! (ref field 'getter) #`"ScmObj vec = Scm_MakeVector(,(size-of arr), SCM_FALSE); int i; for (i=0; i<,(size-of arr); i++) { SCM_VECTOR_ELEMENTS(vec)[i] = ,(unboxer #`\"(obj->,(c-name-of field)[i])\"); } return vec;") ;; (UNKNOWN . XXXX) (set! (ref field 'setter) #f))) (else (set! (ref field 'accessible?) #f))))) (if debug (logformat-color 118 "set-fields: ~a\n" (c-name-of self))) (for-each set-field-getter-n-setter (fields-of self))) ;; mmc: ??? (define-method set-qualifier ((self )) ;; sets GtkObject subclasses :base class, so that Scheme subclass can !! mmc!! ;; be defined. (when (eq? (allocation-type-of self) 'gobject) (set! (qualifier-of self) :base))) ; mmc: what does this do? -> genstub! ;; i have to know this well: (define (fixup-structs) (logformat-color 118 "fixup-structs\n=========\n") ;; Special treatment : GdkBitmap*, GdkPixmap* and GdkWindow* are really ;; synonyms of GdkDrawable*. ;; mmc: this should be meat for me/aliases!! ;; no more needed! '(let ((gdkdrawable (find-type 'GdkDrawable*))) (for-each (lambda (n) (set! (body-of (find-type n)) (body-of gdkdrawable))) '(GdkBitmap* GdkPixmap* GdkWindow*))) ;; GtkAllocation is an alias of GdkRectangle. (let ((gtk-allocation-type (find-type-or-create 'GtkAllocation*)) (gdk-rectangle-struct (find-struct '))) (set! (body-of gtk-allocation-type) gdk-rectangle-struct)) ;; mmc: this should be meat for me/aliases!! typedef GdkRectangle GtkAllocation; (for-each-instance set-superclass ) (for-each-instance set-cpl ) (for-each-instance set-refcounted ) (for-each-instance set-fields )) (define (fixup-structs-after) ;; need to do this after loading hints, for the allocation type of ;; the struct may be modified in hints. (logformat "fixup-structs-after\n") (for-each-instance set-qualifier )) ;; Some heuristics to remove irrelevant functions (define-method set-internal ((self )) (let1 cnam (x->string (c-name-of self)) (when (or (string-suffix? "_ref" cnam) (string-suffix? "_unref" cnam) (string-suffix? "_get_type" cnam)) (set! (internal? self) #t)))) (define-method fix-arg ((self )) ;; This is for (void) argument list (when (equal? (arguments-of self) '(())) (set! (arguments-of self) '())) ; mmc: '(()) -> '() why is it needed. in fact void? ;; Ignore 'const' qualifier (except const-char*) (for-each (lambda (arg) (let* ((type (type-of arg)) (typename (c-name-of type))) (when (and (not (memq typename '(const-char* const-gchar*))) (string-prefix? "const-" (x->string typename))) ;mmc:! typename includes all of that!!! (set! (type-of arg) (find-type-or-create (string->symbol (string-drop (x->string typename) ; const- is 6 chars, hehe 6))))))) (arguments-of self))) (define (fixup-functions) (for-each-instance set-internal ) (for-each-instance fix-arg )) (define (fixup hint-files) (fixup-structs) (fixup-functions) (load-hints hint-files) (fixup-structs-after)) (provide "h2s/fixup") gauche-gtk-0.6+git20160927/lib/h2s/gtk-types-for-emit.scm000066400000000000000000000012351300401456300224220ustar00rootroot00000000000000 (define-module h2s.gtk-types-for-emit (extend h2s.gtk-types) (export scm-class-name-of gtk-predicate-of gtk-type-name-of c-copy-proc-of qualifier-of c-type-of c-predicate-of c-predicate-nullable-of c-class-macro-of ;; needed by fixup & emit! c-boxer-of c-unboxer-of ;; only emitter: getter-of setter-of make-enum values-of ;; c-name-of find-struct make-struct find-function make-function ;; ;; emiter: type? print-body ) ) (select-module h2s.gtk-types-for-emit) (provide "h2s/gtk-types-for-emit") gauche-gtk-0.6+git20160927/lib/h2s/gtk-types-for-fixup.scm000066400000000000000000000014441300401456300226210ustar00rootroot00000000000000 ;; This is the Interface to the `h2s.gtk-types' module ;; provided to `h2s.fixup' (define-module h2s.gtk-types-for-fixup (extend h2s.gtk-types) (export c-name-of scm-name-of ; scm-class-name-of ; gtk-predicate-of ; gtk-type-name-of ; c-copy-proc-of ; qualifier-of ; c-type-of ; c-predicate-of ; c-predicate-nullable-of ; c-class-macro-of ;; needed by fixup & emit! c-boxer-of c-unboxer-of ;; only emitter: ; getter-of ; setter-of make-enum values-of ;; c-name-of find-struct make-struct find-function make-function ;; ;; emiter: type? print-body ) ) (select-module h2s.gtk-types-for-fixup) (provide "h2s/gtk-types-for-fixup")gauche-gtk-0.6+git20160927/lib/h2s/gtk-types.scm000066400000000000000000000317561300401456300207150ustar00rootroot00000000000000 ;; concrete objects (not abstract types) which are exchanged between ;; parsing & emitting. (define-module h2s.gtk-types (export ;; body-of |setter of body-of| c-name-of ;; needed in hint files? ;; implicitely exported? scm-name-of ;; this is `critical' ;; hopefully onle these needed for the fixup fields-of type-of superclass-of allocation-type-of gobject? cpl-of internal? c-free-proc-of c-caster-of allocator-of ;; emiter: scm-class-name-of gtk-predicate-of gtk-type-name-of c-copy-proc-of qualifier-of c-type-of c-predicate-of c-predicate-nullable-of c-class-macro-of ;; needed by hint too. direct-supers-of ;; fixup: element-type-of size-of ;; needed by fixup & emit! c-boxer-of c-unboxer-of ;; fixup: arguments-of return-type-of ;; body-of ; var ??? accessible? ;; only emitter: getter-of setter-of make-enum find-enum values-of ;; c-name-of find-struct make-struct find-function make-function ;; emiter: type? print-body ;scm-type-of get-slot-boxer gtk-base ) (use gauche.mop.instance-pool) (use h2s.objects) (use h2s.track) (use h2s.utils) (use srfi-13) (use srfi-2) (use text.tr) ) (select-module h2s.gtk-types) (define debug #f) (define gtk-base #t) ;backward compatible-> #t! ;; - used in fields and arguments (define-class () ((type :init-keyword :type :accessor type-of) (c-name :init-keyword :c-name :accessor c-name-of) (scm-name :allocation :virtual :accessor scm-name-of ;; what is this? :slot-ref (lambda (o) (string->symbol (string-tr (x->string (c-name-of o)) "_" "-"))) :slot-set! (lambda (o v) #f)) ;; the following slots are used by field info (read-only? :initform #f :accessor read-only?) (accessible? :initform #t :accessor accessible?) (getter :init-keyword :getter :initform #f :accessor getter-of) (setter :init-keyword :setter :initform #f :accessor setter-of) )) (define-method write-object ((self ) port) (format port "<~a ~a>" (type-of self) (c-name-of self))) ;; (define-class ( ) ((c-name :init-keyword :c-name :accessor c-name-of) (fields :init-keyword :fields :accessor fields-of) (internal? :init-value #f :accessor internal?) ;mmc: typedef encountered, but no function signature contains it? ;; - true if this struct is not exposed to Scheme. set `only' by fixup.... yes, by .hint files! `disable-cclass' ;; (c-type :accessor c-type-of) ;; - for struct _GdkFoo, keeps # (superclass :accessor superclass-of) ;; - if inherited, this one keeps of the parent class. (cpl :accessor cpl-of) ;; - class precedence list derived from superclass field. set by fixup. (allocation-type :accessor allocation-type-of :init-form 'simple) ;; - how the C structure should be allocated and freed ;; simple : ScmObj contains the entire structure. ;; gobject : ScmObj points to GObject* ;; indirect : ScmObj points to a mem that should be freed. ;; refcounted : ScmObj points to refcounted object. (scm-class-name :accessor scm-class-name-of) ;; - ; set by make-struct (c-caster :accessor c-caster-of) ;; - GDK_FOO ; set by make-struct (c-predicate :accessor c-predicate-of) ;; - SCM_GDK_FOO_P ; set by make-struct (c-predicate-nullable :accessor c-predicate-nullable-of) ;; - SCM_GDK_FOO_OR_NULL_P ; set by make-struct (c-unboxer :accessor c-unboxer-of) ;; - SCM_GDK_FOO ; set by make-struct (c-boxer :accessor c-boxer-of) ;; - SCM_MAKE_GDK_FOO ; set by make-struct (c-class-macro :accessor c-class-macro-of) ;; -SCM_CLASS_GDK_FOO ; set by make-struct (gtk-predicate :accessor gtk-predicate-of) ;; - GDK_IS_FOO ; set by make-struct (gtk-type-name :accessor gtk-type-name-of) ;; - GDK_TYPE_FOO ; set by make-struct (c-copy-proc :accessor c-copy-proc-of :init-value #f) ;; - Used by indirect struct, keeping C procedure name to copy ;; the data part. can be set in hints file. (c-free-proc :accessor c-free-proc-of :init-value #f) ; example: `gtk_tree_row_reference_free' gtk_tree_path_free ;; - Used by `indirect' struct, keeping C procedure name to free ;; the data part. can be set in hints file. (allocator :init-form #f :accessor allocator-of) ; mmc: is this only relevant for the consturctor/destructor? ;; - Special allocator setting that overrides the default. ;; May be set by hints file. This can be a string for ;; entire allocator body, or an assoc-list of required ;; initargs and the constructor to call. (qualifier :init-value :built-in :accessor qualifier-of) ; mmc: ?? :base -> this means see `genstub'! ;; - define-cclass qualifier. adjusted in fixup. (direct-supers :init-value () :accessor direct-supers-of) ;; - extra direct-supers if this class has a mixin. mmc: interfaces! + the parent ;; mmc: (printer :init-keyword :printer) )) (define-method write-object ((self ) port) (format port "#" (c-name-of self))) (define-method gobject? ((self )) (eq? (allocation-type-of self) 'gobject)) (define-method indirect? ((self )) (eq? (allocation-type-of self) 'indirect)) (define-method refcounted? ((self )) (eq? (allocation-type-of self) 'refcounted)) ;; we don't look at the: typedef a struct _a; ;; This only creates the various default names/stubs ;; for C macros ;; Creates the type! ;; mmc: i have something similar in (define (make-struct name fields) (if debug (logformat-color 157 "make-struct ~a FIELDS:\n~a\n" name fields)) (let* ((c-name (string-drop name 1)) ;; drop preceding '_' (s (make :c-name (string->symbol c-name) :fields fields)) (tn (find-type-or-create (string->symbol #`",|c-name|*"))) ;; ^^^ really, this is `create' (scmname (mixed-case-name->hyphenated-name c-name))) ;; mmc: so, the type of struct _abc_x is abc_x* ?? (set! (c-type-of s) tn) ; <---> (set! (body-of tn) s) (set! (scm-class-name-of s) (string->symbol #`"<,|scmname|>")) (let1 base (string-tr scmname "a-z-" "A-Z_") (set! (c-caster-of s) base) ;mmc: ?? (set! (c-predicate-of s) #`"SCM_,|base|_P") (set! (c-predicate-nullable-of s) #`"SCM_,|base|_OR_NULL_P") (set! (c-unboxer-of s) #`"SCM_,|base|") (set! (c-boxer-of s) #`"SCM_MAKE_,|base|") (set! (c-class-macro-of s) #`"SCM_CLASS_,|base|") ;; Anormality: GdkWindowObject uses GDK_IS_WINDOW macro (set!-values ((gtk-predicate-of s) (gtk-type-name-of s)) (cond ((equal? c-name "GdkWindowObject") (values "GDK_IS_WINDOW" "GDK_TYPE_WINDOW")) ((string-prefix? "PANGO" base) (values #`",(string-take base 6)IS_,(string-drop base 6)" ; mmc: why 6? pango_ ? #`",(string-take base 6)TYPE_,(string-drop base 6)")) ((and gtk-base (string-prefix? "GTK" base)) ;; either GDK_ or GTK_ (values #`",(string-take base 4)IS_,(string-drop base 4)" #`",(string-take base 4)TYPE_,(string-drop base 4)")) ;; wrong!!! GLADE_XML -> GLAD TYPE_E_XML (else (let ((prefix-len (+ 1 (string-scan base "_"))) ) (values (string-append (string-take base prefix-len) "IS_" (string-drop base prefix-len)) (string-append (string-take base prefix-len) "TYPE_" (string-drop base prefix-len))) ;; mmc: i think it's XXX_YYY -> XXXX_IS_YYYY ? and XXX_TYPE_YYY ;;find position of the left-first _ ))))) ;(logformat-color 157 "fields:\n\n" name fields) ;(describe s) s)) (define (find-struct scm-name) (instance-pool-find (lambda (s) (eq? (scm-class-name-of s) scm-name)))) ;; (define-class () ((size :init-keyword :size :accessor size-of) (element-type :init-keyword :element-type :accessor element-type-of))) ;; (define-class ( ) ((c-name :init-keyword :c-name :accessor c-name-of) (values :init-keyword :values :accessor values-of) )) (define (find-enum c-name) (let1 c-name-as-symbol (string->symbol c-name) (instance-pool-find ;; or keep a symbol of c-name & ... (lambda (s) (eq? c-name-as-symbol (c-name-of s)))))) (define (make-enum name values) ;is in C the universe of Enums (their name) disjoint from that of Structs? or only in Gnome (let* ((n (string->symbol name)) (s (make :c-name n :values values))) (set! (body-of (find-type-or-create n)) s) ; !!!! (if debug (logformat "enum ~a: ~a\n" n values)) s)) ;; (define-class ( ) ((c-name :init-keyword :c-name :accessor c-name-of) (return-type :init-keyword :return-type :accessor return-type-of) (arguments :init-keyword :arguments :accessor arguments-of) (internal? :init-value #f :accessor internal?) ;; - true if this function is not exposed to Scheme. set by fixup-functions (scm-name :init-keyword :scm-name :accessor scm-name-of) ;; - scheme name, like gtk-foo for C-function gtk_foo. (body :init-value #f :accessor body-of) )) (define (make-function name ret args) (let1 scm-name (string->symbol (string-tr (x->string name) "_" "-")) (make :c-name name :scm-name scm-name :return-type ret :arguments args))) (define (find-function scm-name) (instance-pool-find (lambda (f) (eq? (scm-name-of f) scm-name)))) ;; - literal stub added by hints file (define-class () (;; s-expr to be placed in the stub file (body :init-keyword :body :accessor body-of) ;; true if this should go to .types file instead of .stub file (type? :init-keyword :type? :accessor type?))) (define-method print-body ((self )) ;; print doesn't include the \" in: ;; (define-type gunichar A type which can hold any UCS-4 character code SCM_CHARP Scm_char2gunichar Scm_gunichar2char) (write (body-of self)) ;mmc: was write !!! print ? (newline) (newline)) ;;; from objects ;; map to stub type signature. (define-method scm-type-of ((self )) (let1 body (body-of self) (cond ((symbol? body) body) ; basic types! ((is-a? body ) ') ((is-a? body ) (scm-class-name-of body)) ;; if the name of gtk-type is XX*, try the type XX. (else (cons 'UNKNOWN (c-name-of self)))))) ;; returns a fn that creates a C code fragment of boxing slot value. mmc: was unboxing/ but it doesn't do it! ;; UGLY - this doesn't deal with array ref. (define-method get-slot-boxer ((self )) ;mmc: what slot??? (let1 body (body-of self) (cond ; mmc: (lambda: x -> scm_makeInteger(x) ((is-a? body ) ;; so the type is a pointer!? (cut string-append (c-boxer-of body) "(" <> ")")) ;not cute ? ((is-a? body ) (cut string-append "Scm_MakeInteger(" <> ")")) ((symbol? body) ;; primitive type. There should be an interface to get this kind ;; of information; maybe lang.c.type module? For now, I hardcode them. (case body (() (cut string-append "SCM_MAKE_CHAR(" <> ")")) (() (cut (string-append "SCM_MAKE_BOOL(" <> ")"))) (( ) (cut string-append "Scm_MakeInteger(" <> ")")) (( ) (cut string-append "Scm_MakeIntegerFromUI(" <> ")")) (( ) (cut string-append "Scm_MakeFlonum(" <> ")")) (( ) (cut string-append "SCM_MAKE_STR_COPYING_SAFELY(" <> ")")) ;; mmc: !! (else #f))) (;; check if it is an embedded structure. (and-let* ((ptrtype (find-type (string->symbol #`",(c-name-of self)*"))) (ptrbody (body-of ptrtype)) ((is-a? ptrbody ))) (if debug (logformat-color 11 "embedded structure!\n")) (cut string-append (c-boxer-of ptrbody) "(&(" <> "))"))) (else #f)))) (provide "h2s/gtk-types") gauche-gtk-0.6+git20160927/lib/h2s/lookup.scm000066400000000000000000000010721300401456300202630ustar00rootroot00000000000000#! /usr/bin/gosh (use h2s.Persistence) (define (main args) ;; lookup (recursively) the type, and show its ... (let ((db-file "/tmp/good.db")) (let1 open-database (lambda (filename) (let ((db (open-type-db filename)) (sdb (open-struct-db filename))) (set! global-sdb sdb) (set! find-type-in-archive-function (cut find-type-in-archive <> db)))) ;; apply (if (slot-bound? recipe 'parsing-function) ((slot-ref recipe 'parsing-function))) ;; ))) gauche-gtk-0.6+git20160927/lib/h2s/objects.scm000066400000000000000000000053571300401456300204150ustar00rootroot00000000000000 ;;;mmc: base class for objects passed from parsing to emitting? ;; (define-module h2s.objects (export find-type find-type-or-create find-type-in-archive-function ;; accessors ... generics!! get-slot-boxer c-name-of scm-type-of body-of |setter of body-of| ;; useless? ;; late-commer: for for-each-instance ;; ) (use gauche.mop.instance-pool) ;; utils? (use h2s.utils) ) (select-module h2s.objects) (define debug #f) ; (define-generic body-of) ; (define-generic |setter of body-of|) ; (define-generic c-name-of) ;; - type (define-class () ((c-name :init-keyword :c-name :accessor c-name-of) ;; symbol, such as 'GdkWindow* (body :init-keyword :body :init-value #f :accessor body-of) ;; has , or if applicable. ;; symbol when this is a primitive type. )) (define-method write-object ((self ) port) (format port "<~a>" (c-name-of self))) ;; this is a hack: we need acyclic dependency of modules. ;; But we need a hook from this, low level module, to call ;; function from a higher module (which looks-up in database). (define find-type-in-archive-function #f) (define (find-type name . rest) (or (instance-pool-find (lambda (item) (eq? (c-name-of item) name))) (if find-type-in-archive-function ;; could be a list! (find-type-in-archive-function name) (begin (if (null? rest) (logformat-color 10 "find-type: not found ~a\n" name)) #f)))) (define (find-type-or-create name) (or (find-type name #t) (begin (if debug (logformat-color 10 "find-type-or-create ~a\n" name)) (make :c-name name)))) ;mmc: no body for now ;; mmc: (define-class () ((alias :init-keyword :alias))) ;; get-slot-boxer depends only on the body? almost. ;; The embedded uses the c-name, to get at another type: the pointer one! So, we should keep a canonical type! ;; (define-method get-slot-boxer ((self )) (get-slot-boxer (slot-ref self 'alias))) (define-method scm-type-of ((self )) ;mmc: this could be the alias name! ;(exit) (scm-type-of (slot-ref self 'alias))) ;; c-name-of remains. b/c find-type uses it :( (define-method write-object ((self ) port) (write-object (slot-ref self 'alias) port)) ;;================================================================ ;; CLASSES ;; (define-method for-each-instance (proc (class )) ; mmc: i would have thought this is standard (for-each proc (instance-pool->list class))) (provide "h2s/objects") gauche-gtk-0.6+git20160927/lib/h2s/parse.scm000066400000000000000000000406001300401456300200640ustar00rootroot00000000000000(define-module h2s.parse (export parse-headers ) (use h2s.objects) (use h2s.gtk-types) (use h2s.utils) (use h2s.track) ;for the inpupt-file param! ; (use macros.aif) ;fixme! (use gauche.parameter) (use file.util) (use srfi-13) (use srfi-11) (use srfi-2) ) (select-module h2s.parse) (define-syntax aif (syntax-rules () [(_ . args) (if-let1 . args)])) (define debug #f) ;; we canonize the C definition into: type****** var-name (define (grok-vardef type name) (if debug (if (and (pair? type) (not (eq? (car type) 'const))) ;; this is only possible from function arguments: search for acons: const XXX *YYYY (logformat-color 87 "grok-vardef: type ~a\n" type) )) (let*-values (((ptrs var) (let1 brk (string-skip name #\*) (values (string-take name brk) (string-drop name brk)))) ((typesig) (if (pair? type) #`",(car type)-,(cdr type),|ptrs|" ;mmc: ??? #`",|type|,|ptrs|"))) ;; (if debug (logformat "grok-vardef: type: ~a\n" (string->symbol typesig))) (make :type (find-type-or-create (string->symbol typesig)) :c-name var))) (define (grok-arraydef type name dim) (receive (ptrs var) (let1 brk (string-skip name #\*) (values (string-take name brk) (string-drop name brk))) (let* ((elt-typesig (if (pair? type) #`",(car type)-,(cdr type),|ptrs|" #`",|type|,|ptrs|")) (typesig #`",elt-typesig[,dim]") (type (find-type-or-create (string->symbol typesig))) (elt-type (find-type-or-create (string->symbol elt-typesig)))) (set! (body-of type) (make :size dim :element-type elt-type)) (make :type type :c-name var)))) ;;================================================================ ;; PASS 1 - PARSER ;; ;; mmc: Q does the parse phase create the tree, the relation between types? (define (parse-headers dir hlist) (for-each (lambda (hdr) (parse-header (build-path dir hdr))) hlist)) ;; | ;; | ;; V (define (parse-header filename) (parameterize ((input-file filename)) (if debug (report #`"*** parsing ,filename")) (with-input-from-file filename parse-body))) ;; | ;; | ;; V (define (parse-body) ;; mmc: why is (parse-body) not outside of rxmatch-case ? (let step ((line (read-line))) (rxmatch-case line (test eof-object?) (#/^struct (_G[dt]k\w+)/ (#f name) (parse-struct name) (parse-body)) (#/^struct (_Pango\w+)/ (#f name) (parse-struct name) (parse-body)) (#/^struct (_Glade\w+)/ (#f name) (parse-struct name) (parse-body)) (#/^struct (_GnomeCanvas\w+)/ (#f name) (parse-struct name) (parse-body)) (#/^struct (_Eog\w+)/ (#f name) (parse-struct name) (parse-body)) ;; only conveniently named are recognized. Others might confuse us!!! ;; Also, note that it must start at bol. ;; and no way to combine typedef struct _a{....} a; !!! Must be separate. (#/^PANGO_AVAILABLE_IN_/ () (parse-body)) ;; this new addition of preprocessor symbols in Pango interferes with ;; parsing. we just skip. (#/^typedef enum/ () (parse-enum) (parse-body)) ;; mmc: ;; typedef GtkTextBuffer GtksourceviewTextBuffer; (#/^typedef\s+(\w+)\s+(\w+)\s*\;$/ (#f old new) (unless (string-suffix? "Class" old) ;new? (copy-type! old new)) (parse-body)) ;; fixme: "const GSlist" functions ! (#/^(?:const\s+)?([\w\*_]+)\s+((\*+)\s*)?((g[dt]k|pango|glade|gnome_canvas|eog)_[\w_]+)\s*\((.+)$/ (#f ret #f ptr fn #f rest) ;; fixme: const -> i could recycle the memory! (parse-function (if ptr #`",|ret|,|ptr|" ret) fn rest) ;; fixme: (parse-body) (step (read-line))) ;; typedef struct _GdkDrawable GdkPixmap; ;; typedefa struct _a a; is ignored!! (#/^typedef\s+struct\s+(\w+)\s+(\w+)\s*\;$/ (#f struct-name type-name) (unless (string=? struct-name (string-append "_" type-name)) (if debug (logformat-color 172 "new alias for the struct ~a: ~a\n" struct-name type-name)) (copy-type! (string-drop struct-name 1) type-name) ;; fixme: why did I comment it out? ;; later! '(let1 old-type (find-type (string-drop struct-name 1)) (set! (body-of (find-type-or-create (string->symbol type-name))) ;; struct !! (body-of old-type)))) (parse-body)) ;; workaround for /usr/include/gtkextra-2.0/gtkextra/gtksheet.h ;; GtkWidget * ;; gtk_sheet_new_browser (guint rows, guint columns, const gchar *title); ;; (#/^(?:const\s+)?([\w\*_]+)\s*(\s+(\*+))?$/ (all ret pointers) ;; append the second line and see: (if debug (logformat "another line read to form a parsing unit\n")) (step (string-append line " " (read-line))));; (string-drop-right line 1) ;; fixme: this doesn't skip over multi-line `fat'; (#/^.*$/ (all) ;;else (if debug (logformat "non-matched line: ~a\n" all)) (parse-body))) )) (define (copy-type! old new) ;; Shiro made this hack: (& i try to extend it) ;; GdkWindow ;;(set! (body-of (find-type n)) (body-of gdkdrawable)) ;; body is important for: `get-slot-boxer' (if debug (logformat-color 196 "copy-type!: ~a -> ~a\n" old new)) ;(sys-exit 0) (if (find-type new #t) (logformat-color (color* yellow) "copy-type!: ~a has already been defined\n" new) ;(logformat-color '(5 5 1) "copy-type!: ~a ~a\n" old new) ;yellow '(1 1 1)gunichar (and-let* ((c-name old) ;; (string-drop name 1) drop preceding '_' (scmname (mixed-case-name->hyphenated-name c-name))) ;((logformat-color (color* green) "scm name of the old type: ~a\n" scmname))) (cond ;; gtk doesn't distinguish it. i can/do for now. ;; so, i don't want to rely on the Glib type system, hmmmmm. ;; SCM_MAKE_GTK_SOURCE_MARKER -> SCM_GOBJECT_BOX -> ScmObj Scm_MakeGObject(void *obj) -> g_object_get_qdata ;; i would need, that SCM_MAKE_GTK_SOURCE_MARKER added a tag to tell more: ;; or ;; ignore the distinction: then the source_marker functions should `just' accept the more general type. ;; that is: everywhere i use the stricter type, i should output the general. ((find-struct (string->symbol #`"<,|scmname|>")) => (lambda (old-struct) ;; (if #t ;; version 2 (let* ((old-type (find-type (string->symbol (string-append old "*")) #t)) (new-type-name (string->symbol (string-append new "*"))) ) (aif new-type (find-type new-type-name) (begin ;; fixme: (slot-set! new-type 'body (body-of old-type))) ;(set! new-type (make :c-name :alias old-type)) ;; string-append ;(logformat-color (color* green) "\tit is a struct ~a\t type ~a found\n" #`"<,|scmname|>" ; (if old-type "" "NOT")) ;; (slot-set! new-type 'alias old-type) ;(logformat "...so we created a c-named: ~a\n" (c-name-of new-type)) 1;new-type ) ;; version 1 (begin ;; fixme: base types: uint & etc ;(logformat-color (color* green) "\tit is a struct ~a\n" #`"<,|scmname|>") ;; i could even make it inherit. (make-struct (string-append "_" new) (fields-of old-struct)))))) ;; ((find-type (string->symbol old) #t) => (lambda (old-type) ;body (body-of self) ;(symbol? body) (set! (body-of (find-type-or-create (string->symbol new))) (body-of old-type)) ;(make :c-name (car entry) :body (cadr entry)) ;(make :c-name (string->symbol new)) )) ;; (else (logformat-color 'red "PROBLEM: copy-type! from ~a but that type is unknown now!" old))) (let1 old-type (find-type (string->symbol old) #t) (if old-type (set! (body-of (find-type-or-create (string->symbol new))) (body-of old-type)))) (let1 old-type (find-type (string->symbol (string-append old "*"))) (when old-type (make :c-name (string->symbol (string-append new "*")) :body (body-of old-type)) (logformat-color 196 "(typedef) copied the body into: from ~a\n" old-type)))))) ;; collect the slots and the call .... `make-struct' ;; what are the slots: ;; ;; ;; ( ( ) symbol ..... ) ;; ;; (define (parse-struct name) (define (err-eof) (errorf "EOF while parsing struct ~s" name)) (define (remove-gseal line) ;; an ad-hoc stuff to remove GSEAL macro. (regexp-replace #/GSEAL\s*\(([^\)]+)\)/ line "\\1")) (define (parse-struct-body) (let loop ((line (read-line)) (fields '())) (rxmatch-case (remove-gseal line) (test eof-object? (err-eof)) ;; empty (#/^\s*$/ () (loop (read-line) fields)) ;; G style wants them on separate line!? (#/^\{/ () (loop (read-line) fields)) (#/^\}/ () (make-struct name (reverse fields))) ;mmc: exit here! (test has-comment? (skip-comment line (cut loop <> fields) err-eof)) ;; a_b_*c* a*b*c_ef[abcde_dl] : 3; ;(#/^\s+([\w\*_]+)\s+([\w\*_]+)(\[([\w_]+)\])?\s*(:\s*\d+\s*)?\;/ ;; a_b*** **a_b [a_b] : 23: (#/^\s+([\w_]+\**)\s+(\**[\w_]+)(\[([\w_]+)\])?\s*(?::\s*\d+\s*)?\;/ (match type var array bits) ; ;; #f ;; mmc: i see it (#f type var array bits) bug? (if (and (not array) bits) (logformat-color 123 "mmc: bits: ~a\n" bits)) (if array (begin (logformat-color 197 "mmc: found C array: ~a\n\tline was: ~a\n" array line) (loop (read-line) (cons (grok-arraydef type var bits) fields))) (loop (read-line) (cons (grok-vardef type var) fields)))) ;; the original: (#/^\s+([\w\*_]+)\s+([\w\*_]+)(\[([\w_]+)\])?\s*(:\s*\d+\s*)?\;/ (#f type var #f array) (logformat-color 123 "mmc: your regexp is wrong!\n~a\n" line) (sys-exit 1)) ;; function pointer - `ignore!' But the function cannot be used then! ... err. here we are parsing Struct! (#/^\s+[\w\*_]+\s+\**\([\w\*_]+\)(.*)/ (#f rest) (let loop2 ((line rest)) (rxmatch-case line (test eof-object? (err-eof)) (#/\)\;/ () (loop (read-line) fields)) (else (loop2 (read-line)))))) (#/^\s+([\w\*_]+)\s+([\w\*_]+)\s*,(.*)$/ (#f type var rest) ;; something like: int x,y, ;; z,w; (let loop2 ((rest rest) (fields (cons (grok-vardef type var) fields))) (rxmatch-case rest (#/\s*([\w\*_]+)\s*\;/ (#f var) (loop (read-line) (cons (grok-vardef type var) fields))) (#/\s*([\w\*_]+)\s*,(.*)$/ (#f var rest) (loop2 rest (cons (grok-vardef type var) fields))) (else (warn "~s in ~a" line name) (loop (read-line) fields))))) (else (warn "~s in ~a" line name) (loop (read-line) fields))))) (define (skip-struct name) (if debug (logformat-color 200 "Skipping a class/interface struct ~a.\n" name)) (let loop ((line (read-line))) (rxmatch-case line (test eof-object? (err-eof)) (#/^\{/ () (loop (read-line))) (#/^\}/ () '()) (else (loop (read-line)))))) (if debug (logformat-color 190 "parsing struct ~a\n" name)) ;; we are not interested in these !!! What do they do? keep gobject `methods' only? (if (string-suffix? "Class" name) (skip-struct name) (parse-struct-body))) ;; mmc: we have already thrown the name ? No the C enum is enum {....} _Name_; (define (parse-enum) (define (err-eof) (error "EOF while parsing enum")) (let loop ((line (read-line)) (enums '())) (rxmatch-case line (test eof-object? (err-eof)) (#/^\{/ () (loop (read-line) enums)) (#/^\}\s*([\w_]+)/ (#f name) (make-enum name (reverse enums))) ; -----> ;; empty line: (#/^\s*$/ () (loop (read-line) enums)) ;; preprocessor directive: (#/^\s*#\s*\w+/ () (loop (read-line) enums)) ;; (test has-comment? (skip-comment line (cut loop <> enums) err-eof)) ; what if?: new_value, /* boring comment*/ (#/\s+([\w_]+),?/ (#f enum) (loop (read-line) (cons enum enums))) (#/\s+([\w_]+)\s+=/ (#f enum) ; name = ...whatever... we are not interested in that detail! (loop (read-line) (cons enum enums))) (else (warn "~s in enum" line) (loop (read-line) enums)) ))) ;; return-type name-including-* (pointers!) rest is rest-of-line, i.e. the arguments, after the "(" (define (parse-function ret name rest) (define (err-eof) (errorf "EOF while parsing function ~s" name)) (define (grok-arg argstr) ; "int a" (rxmatch-case (string-trim-both argstr) ; remove spaces at extremes (#/^const\s+(.+)$/ (#f rest) (let1 r (grok-arg rest) (acons 'const (car r) (cdr r)))) ;(acons 1 2 3) -> ((1 . 2) . 3) (#/^([\w\*_]+)\s+([\w\*_]+)$/ (#f type name) (cons type name)) ;; function: , int (f)(int*, char*) !!! (#/^([\w\*_]+)\s+\(([\w\*_]+)\)/ (#f type name) (acons 'fn type name)) (#/^void$/ () '()) (#/^...$/ () (cons "VARARG" "...")) (else (warn "can't grok arg ~a in ~a" argstr name) '("UNKNOWN" . "UNKNOWN")))) (define (finish-function ret name rargs) (make-function name (find-type-or-create (string->symbol ret)) (reverse (map (lambda (arg) (let1 a (grok-arg arg) (if debug (logformat "arg: ~a\n" a)) (if (null? a) a (grok-vardef (car a) (cdr a))))) ; ??? rargs)))) (if debug (logformat-color 245 "parsing functions ~a\n" name)) (let loop ((line rest) ;First line (args '())) (rxmatch-case line (test eof-object? (err-eof)) ;;empty line (#/^\s*$/ () (loop (read-line) args)) ;; (test has-comment? (skip-comment line (cut loop <> args) err-eof)) ;Is this the reason we cannot invoke loop after rxmatch-case? ;; (#/\s*([^,]+),(.*)/ (#f arg rest) ; get XXX XXX, <--rest---> (loop rest (cons arg args))) ;; (#/\s*(.+)\).*\;/ (#f arg) (finish-function ret name (cons arg args))) (else (warn "~s in ~a" line name) (loop (read-line) args))))) (define (has-comment? line) (string-scan line "/*")) (define (skip-comment line cont error-eof) (receive (prev next) (string-scan line "/*" 'both) (cond ((string-scan next "*/" 'after) => (lambda (n) (cont #`",|prev| ,|n|"))) (else (let loop ((line (read-line))) (rxmatch-case line (test eof-object? (error-eof)) (#/\*\/(.*)/ (#f rest) (cont #`",|prev| ,|rest|")) (else (loop (read-line))))))))) (provide "h2s/parse") gauche-gtk-0.6+git20160927/lib/h2s/program.scm000066400000000000000000000005361300401456300204250ustar00rootroot00000000000000 ;; just collect the USED modules (define-module h2s.program (extend h2s.top h2s.objects h2s.parse h2s.emit h2s.gtk-types h2s.fixup h2s.utils h2s.persistence ;(use ) )) (select-module h2s.program) (provide "h2s/program") gauche-gtk-0.6+git20160927/lib/h2s/top.scm000066400000000000000000000075121300401456300175610ustar00rootroot00000000000000 (define-module h2s.top (export init-hardwired standard-parse-n-emit ) (use h2s.objects) (use h2s.gtk-types) ; (use h2s.persistence) (use h2s.fixup) (use h2s.emit) ;; h2s.parse (use h2s.utils) ) (select-module h2s.top) (define-class () ( (hint-files :init-keyword :hint-files) (types-file :init-keyword :types-file) (inits-file :init-keyword :inits-file) (header-file :init-keyword :header-file) (include-file :init-keyword :include-file) (init-function :init-keyword :init-function) ;; parsing what? (parsing-function :init-keyword :parsing-function) )) (define debug #f) (define (init-hardwired) ;; define primitive types (for-each (lambda (entry) (if debug (logformat "init: ~a\n" (car entry))) (make :c-name (car entry) :body (cadr entry))) '((gint ) (gint8 ) (gint16 ) (gint32 ) (glong ) (gshort ) (guint ) (guint8 ) (guint16 ) (guint32 ) (gulong ) (guchar ) (gushort ) (gboolean ) (gfloat ) (gdouble ) (long ) (int ) (short ) (char ) (void ) (float ) (double ) ;; mmc: (gunichar ) ;uint32 ;(PangoGlyphUnit ) ;; cp: PangoGlyphItem PangoLayoutRun ;; C string business is tricky. We can only treat the case that ;; passing const char * or const gchar * - in those cases, gtk copies ;; the passed string immediately, so we can safely pass the string ;; from ScmGetStringConst*. (const-char* ) (const-gchar* ) ;; Generic GObject (GObject* ) ;; mmc: Will this solve it? (GObject ) ;; This is used to box the returned allocated gchar* (gchar* ) ;; Opaque types (PangoContext* ) (PangoLanguage* ) (PangoAttrList* ) (PangoLayoutIter* ) (GdkAtom ) (GdkRegion* ) (GdkPixbufFormat* ) (GtkTreePath* ) (GtkTreeRowReference* ) ;; GdkEvent is a union. (GdkEvent* ) ;; GtkAllocation is simply an alias of GdkRectangle (GtkAllocation* ) ;; Interfaces (GtkEditable* ) (GtkTreeModel* ) (GtkTreeSortable* )))) (define (standard-parse-n-emit recipe input-db output-db) (init-hardwired) (let1 open-database (lambda (filename) ;; (logformat "using GTK definitsion in (BDB) file ~a\n" filename) (let ((db (open-type-db filename)) (sdb (open-struct-db filename))) (set! global-sdb sdb) (set! find-type-in-archive-function (cut find-type-in-archive <> db)))) (if input-db (open-database input-db)) ;; apply (if (slot-bound? recipe 'parsing-function) ((slot-ref recipe 'parsing-function))) ;; (report "Fixing up ...") (fixup (slot-ref recipe 'hint-files)) (report "Generating ...") (emit-all (ref recipe 'types-file) (ref recipe 'header-file) (ref recipe 'include-file) (ref recipe 'init-function) (ref recipe 'inits-file)) ;; ;(if output-db (dump-all output-db)) )) (provide "h2s/top") gauche-gtk-0.6+git20160927/lib/h2s/track.scm000066400000000000000000000042301300401456300200550ustar00rootroot00000000000000 ;; mmc: by the means of a parameter, we record a value (filename) for each created (derived) object. ;; Then we can get a list of objects (in the right order) for each (used) value. ;; consumers should keep the parameter `input-file', ;; and generate the derived objects. ;; we keep a class-wide (per derived ?) alist of (file . object) from which ... ;; in the end, it can use: ;; `for-each-source-file' ;; fixme: i don't like this? (define-module h2s.track (export get-files&definitions for-each-source-file input-file ) (use gauche.parameter) (use gauche.mop.instance-pool) (use h2s.utils) ) (select-module h2s.track) (define-class () ((source-file) ;:accessor source-file-of (files&definitions :allocation :class :initform '()))) (define-method initialize ((self ) initargs) (next-method) ;(logformat "initialize : ~s->~s\n" initargs (ref self 'c-name)) (let1 file (sys-basename (input-file)) ;mmc: parameter ;; buggy! (set! (source-file-of self) file) (slot-set! self 'source-file file) (let1 p (assoc file (slot-ref self 'files&definitions)) ; we have this global alist filename -> list of definitions (if p (push! (cdr p) self) (slot-push! self 'files&definitions (list file self))))) ;(logformat "initialize : ~s->~s\n" initargs (ref self 'c-name)) self) ;; call proc with source file name and a list of objects defined in that file. (define (for-each-source-file proc) (for-each (lambda (def-list) ;; filename definitions. in order of appearance in the file!! (proc (car def-list) (reverse (cdr def-list)))) ;; mmc: (get-files&definitions) ;(reverse (class-slot-ref ; 'files&definitions)) )) (define (get-files&definitions) (reverse (class-slot-ref 'files&definitions))) ;; Keeps input file name during parsing (define input-file (make-parameter #f)) (provide "h2s/track") gauche-gtk-0.6+git20160927/lib/h2s/utils.scm000066400000000000000000000033651300401456300201210ustar00rootroot00000000000000;; some general utilities (define-module h2s.utils (use gauche.parameter) (export logformat logformat-color report mixed-case-name->hyphenated-name verbose) ) (select-module h2s.utils) (define verbose (make-parameter #t)) ;;================================================================ ;; UTILITIES ;; (define (report msg) (when (verbose) (display msg (current-error-port)) (newline (current-error-port)))) (define (logformat . args) (apply format (current-error-port) args)) ;; NB: original mmc's version uses terminal colors. This is just a ;; placeholder until we reimplment it. (define (logformat-color color . args) (apply logformat args)) ;; FooBarBaz => foo-bar-baz ;; FooZBar => foo-zbar ;; FooZZBar => foo-zz-bar (define (mixed-case-name->hyphenated-name name) (define (loop current prev ncaps) (cond ((eof-object? current) (write-char (char-downcase prev))) ((char-upper-case? current) (if (char-lower-case? prev) (begin (write-char prev) (write-char #\-) (loop (read-char) current 1)) (begin (write-char (char-downcase prev)) (loop (read-char) current (+ ncaps 1))))) ((char-lower-case? current) (when (> ncaps 2) (write-char #\-)) (write-char (char-downcase prev)) (loop (read-char) current 0)) (else (write-char (char-downcase prev)) (loop (read-char) current 0)))) (with-output-to-string (lambda () (with-input-from-string name (lambda () (let1 c0 (read-char) (unless (eof-object? c0) (loop (read-char) c0 0)))))))) (provide "h2s/utils") gauche-gtk-0.6+git20160927/src/000077500000000000000000000000001300401456300155735ustar00rootroot00000000000000gauche-gtk-0.6+git20160927/src/GDKFILES000066400000000000000000000004221300401456300167040ustar00rootroot00000000000000gdk.h gdkcolor.h gdkcursor.h gdkdisplay.h gdkdnd.h gdkdrawable.h gdkenumtypes.h gdkevents.h gdkfont.h gdkgc.h gdkimage.h gdkinput.h gdkkeys.h gdkpango.h gdkpixbuf.h gdkpixmap.h gdkproperty.h gdkregion.h gdkrgb.h gdkscreen.h gdkselection.h gdktypes.h gdkvisual.h gdkwindow.h gauche-gtk-0.6+git20160927/src/GDKPIXBUFFILES000066400000000000000000000001561300401456300176260ustar00rootroot00000000000000gdk-pixbuf-features.h gdk-pixbuf-loader.h gdk-pixbuf.h gdk-pixdata.h gdk-pixbuf-core.h gdk-pixbuf-transform.h gauche-gtk-0.6+git20160927/src/GENERATE000066400000000000000000000030451300401456300167120ustar00rootroot00000000000000Memo for autogenerated sources. The defs file will be the way. But for now, I can't find reliable source of defs file for gtk-2.0 and so I take my own. [Source] h2stub.scm - A quick hacked generation script. pango-lib.hints, gdk-lib.hints, gtk-lib.hints - Scheme files that is loaded by h2stub.scm to correct stuff that h2stub.scm couldn't make out from parsing C header files. [Generated files] gtk-lib.h - Contains decls of Scheme wrapper classes of Gtk objects. gtk-lib.inits - A C code fragment that calls initialization routines of autogenerated stuff. Included from gauche-gtk.c. gtk-lib.types - A fragment of stub file that specifies stub type definitions. This is included from every autogenerated stub files. *.stub - All stub files except gauche-*.stub [Type mapping strategy] There seem to be three categories in Gtk objects. (1) The object that inherit GObject In Scheme world, this is encapsulated by ScmGObject. (So there's no individual struct definition). Type query is done with help of Gtk type system. (2) The object that doesn't inherit GObject, but does it's own ref counting. In Scheme world, a wrapper structure is defined, which keeps a pointer to the real structure. (3) The helper structure that doesn't do ref counting at all. This object is designed mostly for transient operation. In Scheme world, a structure that contains the whole original struct is defined. gauche-gtk-0.6+git20160927/src/GTKFILES000066400000000000000000000045631300401456300167360ustar00rootroot00000000000000gtkaboutdialog.h gtkaccelgroup.h gtkaccellabel.h gtkaccelmap.h gtkaccessible.h gtkaction.h gtkactiongroup.h gtkadjustment.h gtkalignment.h gtkarrow.h gtkaspectframe.h gtkbbox.h gtkbin.h gtkbindings.h gtkbox.h gtkbutton.h gtkcalendar.h gtkcelllayout.h gtkcellrenderer.h gtkcellrenderercombo.h gtkcellrendererpixbuf.h gtkcellrendererprogress.h gtkcellrenderertext.h gtkcellrenderertoggle.h gtkcellview.h gtkcheckbutton.h gtkcheckmenuitem.h gtkclipboard.h gtkclist.h gtkcolorbutton.h gtkcolorsel.h gtkcolorseldialog.h gtkcombo.h gtkcombobox.h gtkcomboboxentry.h gtkcontainer.h gtkctree.h gtkcurve.h gtkdialog.h gtkdnd.h gtkdrawingarea.h gtkeditable.h gtkentry.h gtkentrycompletion.h gtkenums.h gtkeventbox.h gtkexpander.h gtkfilesel.h gtkfixed.h gtkfilechooserbutton.h gtkfilechooserdialog.h gtkfilechooserwidget.h gtkfontbutton.h gtkfontsel.h gtkframe.h gtkgamma.h gtkgc.h gtkhandlebox.h gtkhbbox.h gtkhbox.h gtkhpaned.h gtkhruler.h gtkhscale.h gtkhscrollbar.h gtkhseparator.h gtkiconfactory.h gtkicontheme.h gtkiconview.h gtkimage.h gtkimagemenuitem.h gtkimcontext.h gtkimcontextsimple.h gtkimmulticontext.h gtkinputdialog.h gtkinvisible.h gtkitem.h gtkitemfactory.h gtklabel.h gtklayout.h gtklist.h gtklistitem.h gtkliststore.h gtkmain.h gtkmenu.h gtkmenubar.h gtkmenuitem.h gtkmenushell.h gtkmenutoolbutton.h gtkmessagedialog.h gtkmisc.h gtknotebook.h gtkobject.h gtkoldeditable.h gtkoptionmenu.h gtkpaned.h gtkpixmap.h gtkplug.h gtkpreview.h gtkprogress.h gtkprogressbar.h gtkradioaction.h gtkradiobutton.h gtkradiomenuitem.h gtkradiotoolbutton.h gtkrange.h gtkrc.h gtkruler.h gtkscale.h gtkscrollbar.h gtkscrolledwindow.h gtkselection.h gtkseparator.h gtkseparatormenuitem.h gtkseparatortoolitem.h gtksettings.h gtksignal.h gtksizegroup.h gtksocket.h gtkspinbutton.h gtkstatusbar.h gtkstock.h gtkstyle.h gtktable.h gtktearoffmenuitem.h gtktextmark.h gtktextbuffer.h gtktextview.h gtktextchild.h gtktexttag.h gtktextiter.h gtktexttagtable.h gtktipsquery.h gtktoggleaction.h gtktogglebutton.h gtktoggletoolbutton.h gtktoolbar.h gtktoolbutton.h gtktoolitem.h gtktooltips.h gtktreednd.h gtktreemodel.h gtktreemodelfilter.h gtktreemodelsort.h gtktreeselection.h gtktreestore.h gtktreeview.h gtktreeviewcolumn.h gtktypeutils.h gtkuimanager.h gtkvbbox.h gtkvbox.h gtkviewport.h gtkvpaned.h gtkvruler.h gtkvscale.h gtkvscrollbar.h gtkvseparator.h gtkwidget.h gtkwindow.h gtktreesortable.h gtkcelleditable.h gtkfilechooser.h gauche-gtk-0.6+git20160927/src/Makefile.in000066400000000000000000000066171300401456300176520ustar00rootroot00000000000000# # Makefile.in for Gauche-gtk/src # # prelude --------------------------------------------- .SUFFIXES: .stub .stub.c : $(GOSH) genstub $< # General info SHELL = @SHELL@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ datarootdir = @datarootdir@ srcdir = @srcdir@ VPATH = $(srcdir) top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ # These may be overridden by make invocators DESTDIR = # These are set by configure # NB: cc and various flags must match the ones used to compile Gauche, # so the make invocator shouldn't casually override them. CC = @CC@ CFLAGS = @DEFS@ @CFLAGS@ @X_CFLAGS@ -I. `gauche-config -I` `gauche-config --so-cflags` $(GTK_CFLAGS) LDFLAGS = $(GTK_LDFLAGS) @LDFLAGS@ `gauche-config -L` `gauche-config --so-ldflags` LIBS = $(GTK_LIBS) @LIBS@ `gauche-config -l` @X_LIBS@ @X_PRE_LIBS@ -lXext -lX11 GOSH = @GOSH@ GAUCHE_CONFIG = @GAUCHE_CONFIG@ INSTALL = @GAUCHE_INSTALL@ OBJEXT = @OBJEXT@ EXEEXT = @EXEEXT@ SOEXT = @SOEXT@ # Other definitions GTK_CFLAGS = `pkg-config --cflags gtk+-2.0` GTK_LDFLAGS = `pkg-config --libs-only-L gtk+-2.0` GTK_LIBS = `pkg-config --libs-only-l gtk+-2.0` GEN_OBJS = @GEN_OBJS@ GEN_SRCS = @GEN_SRCS@ GEN_STUBS = @GEN_STUBS@ ARCHFILES = gauche-gtk.$(SOEXT) SCMFILES = HEADERS = gauche-gtk.h gtk-lib.h gtk-lib.types GAUCHE_PKGINCDIR = $(DESTDIR)@GAUCHE_PKGINCDIR@ GAUCHE_PKGLIBDIR = $(DESTDIR)@GAUCHE_PKGLIBDIR@ GAUCHE_PKGARCHDIR = $(DESTDIR)@GAUCHE_PKGARCHDIR@ # build ----------------------------------------------- TARGET = gauche-gtk.$(SOEXT) OBJS = gtk_head.$(OBJEXT) gauche-gtk.$(OBJEXT) \ gauche-glib.$(OBJEXT) gauche-gdklib.$(OBJEXT) \ $(GEN_OBJS) \ gtk_tail.$(OBJEXT) CONFIG_GENERATED = Makefile config.cache config.log config.status \ gtk-config.h GENERATED = $(GEN_SRCS) $(GEN_STUBS) \ gtk-lib.h gtk-lib.inits gtk-lib.types gauche-glib.c \ gauche-gdklib.c gtk_head.c gtk_tail.c TESTFILES = test-native$(EXEEXT) test-native.$(OBJEXT) all : $(TARGET) gauche-gtk.$(SOEXT) : $(OBJS) $(CC) $(LDFLAGS) gauche-gtk.$(SOEXT) $(OBJS) $(LIBS) $(OBJS) : gauche-gtk.h gtk-lib.h gauche-gtk.$(OBJEXT) : gtk-lib.inits stubs : h2s-gtk.scm gdk-lib.hints gtk-lib.hints pango-lib.hints $(GOSH) -I../lib ./h2s-gtk.scm gauche-glib.c : gauche-glib.stub gtk-lib.types gauche-gdklib.c : gauche-gdklib.stub gtk-lib.types gtk-lib.h gtk-lib.types gtk-lib.inits: @echo "Please run 'make stubs' first." @exit 1 gtk_head.c gtk_tail.c : $(GAUCHE_CONFIG) --fixup-extension gtk gauche_gtk # tests ----------------------------------------------- check : all @rm -f test.log $(GOSH) -I. -I../lib test-gdk.scm >> test.log $(GOSH) -I. -I../lib test-gtk.scm >> test.log test-native$(EXEEXT) : test-native.$(OBJEXT) $(OBJS) $(CC) -L. $(GTK_LDFLAGS) `$(GAUCHE_CONFIG) -L` -o test-native test-native.$(OBJEXT) $(OBJS) -luvector -lgauche $(LIBS) # install ---------------------------------------------- install : all $(INSTALL) -m 444 -T $(GAUCHE_PKGINCDIR) $(HEADERS) $(INSTALL) -m 444 -T $(GAUCHE_PKGLIBDIR) $(SCMFILES) $(INSTALL) -m 555 -T $(GAUCHE_PKGARCHDIR) $(ARCHFILES) # clean ------------------------------------------------ clean : rm -rf core $(TARGET) $(OBJS) $(TESTFILES) *~ test.log so_locations distclean : clean rm -rf $(CONFIG_GENERATED) maintainer-clean : clean rm -rf $(CONFIG_GENERATED) $(GENERATED) configure gauche-gtk-0.6+git20160927/src/PANGOFILES000066400000000000000000000002721300401456300171460ustar00rootroot00000000000000pango-attributes.h pango-break.h pango-context.h pango-coverage.h pango-enum-types.h pango-font.h pango-fontmap.h pango-fontset.h pango-glyph.h pango-item.h pango-layout.h pango-types.h gauche-gtk-0.6+git20160927/src/README.hints000066400000000000000000000173201300401456300176020ustar00rootroot00000000000000Gauche-gtk scans gtk header files to extract API information to generate stub files and some header files, using h2stub.scm program. Since C header files don't provide all necessary information, and some C construct is too hard to parse by ad-hoc parser, the extracted information is not enough to generate complete APIs. Generally, unrecognized API doesn't show up in Scheme side. To compensate it, h2stub.scm reads in manually-prepared 'hints' files, which fills out the missing parts. Due to the large number of Gtk2 APIs, hints entries haven't covered all of them yet. If you don't find Scheme API for some Gtk2 calls, it is likely that the necessary hint entry hasn't written. (There are some APIs that intentionally dropped from Scheme, though, mostly because they are irrelevant for Scheme programs). The stub generation process is done at Gauche-gtk packaging time, so as far as you download the release tarball, you don't see h2stub.scm working. If you check out CVS version, however, you don't see many *.stub files, and need to run 'make stubs' to generate them. This file explains how to write hints file entries to some extent. Note that I regard the whole h2stub stuff is a temporary solution, and the current spec is just an ad hoc design rather than a well thought-out one. It may be changed in incompatible way in the later versions. [Hint files] Currently, there are three hint files. gtk-lib.hints - hints used to generate gtk*.stub gdk-lib.hints - hints used to generate gdk*.stub pango-lib.hints - hints used to generate pango-*.stub Entries in the hints file also affect the following generated files. gtk-lib.h - definitions and declarations for generated stubs. gtk-lib.inits - initialization function. gtk-lib.types - Set of define-type stub entries, used commonly by all stub files. Each hints file consists of hint entries, grouped by the target header files. The following is an excerpt from gtk-lib.hints: ;;================================================================== ;; gtkaccelgroup.h ;; (input-file "gtkaccelgroup.h") ;; gtk_accel_group_connect (define-cproc-fix gtk-accel-group-connect (fix-arguments! '(accel_group:: accel_key:: accel_mods:: accel_flags:: handler::)) (fix-body! "gtk_accel_group_connect(accel_group, accel_key, accel_mods, accel_flags, Scm_MakeGClosure(handler)); SCM_RETURN(SCM_UNDEFINED);")) Here, input-file hint entry declares the following hints entries are related to the APIs extracted from gtkaccelgroup.h. The input-file declaration specifies which stub file the generated code from the following entries should go. It is effective until tne next input-file declaration is seen. Other top-level expressions are hint directives, described below. [Hint directives] Hint directives can do the following things: * Insert new stub entries. * Correct information gathered by scanning C files that affect the generated stub entries. Inserting new stub entries .......................... The following directives are just inserted to the result stub file directly. define-cclass arg ... define-cproc arg ... define-enum arg ... define-constant arg ... define-type arg ... They can be used when h2stub failed to see necessary API/type/enum declarations in the header file at all. You can also insert raw C code piece by the following directive: raw-code string ... string ... are joined with newlines, and inserted to the resulting stub file. There's also a convenience directive to generate appropriate Scheme class code for a C structure. make-opaque is a string of the structure. is either one of :gobject, :indirect, or :refcounted. This should be used iff h2stub failed to see the type declaration of C structure . If is :gobject, a stub code that treats as a GObject is generated. That means the Scheme class inherits , and the generated constructor and finalizer handle reference counting. If is :refcounted, a stub code assumes is not a GObject, but maintained by reference counting mechanism, by functions whose name follows the Gtk naming conventions (e.g. for GtkFooBar, it has gtk_foo_bar_ref and gtk_foo_bar_unref). The generated constructor and finalizer handle reference counting, but the Scheme class doesn't inherit . If is :indirect, a stub code assumes the instance of won't be deallocated while Scheme is running, and doesn't generate any memory management code. The generated constructor only boxes the given pointer. Correcting information ...................... Sometimes h2stub does detect an API/type declaration, but failed to parse some parts of it, causing generating wrong stub entry or failed to generate the stub entry. (You can find the latter case by looking at the generated stub file. The entries that can't be generated are written out as comments, something like the followig: ;; gtk_widget_new ;; (define-cproc gtk-widget-new (type::(UNKNOWN . GType) first_property_name:: ...::(UNKNOWN . VARARG)) (return gtk_widget_new)) In this case, h2stub doesn't know how to handle GType and vararg arguments, so it couldn't genereate appropriate stub entry for gtk-widget-new. To fix this problem, you have to use one of the following directives. disable-cproc disable-cclass These tell h2stub _not_ to generate the stub entry for , although h2stub recognizes the declaration of from the C header files. There are some cases that you don't want to expose certain C functions/structures to Scheme; some of them are unnecessary to write Scheme programs, and some of them would cause inconsistency in Scheme data. define-cproc-fix ... This fixes the parsed C procedure declaration. The information of the parsed C procedure is contained in an instance of class. This directive first binds the instance to a variable 'self', then evaluates .... You can change the slot values of the instance to fix up whatever broken. See h2stub.scm for the details of the . Two macros are provided to be used in for the convenience: fix-arguments This changes the argument list of the function. fix-body This changes the body of the function. define-cclas-fix ... This fixes the parsed C structure declaration. The information of the structure is contained in an instance of class. This directive first binds a variable 'self' to the instance, then evaluates .... You can change the slot values of the instance to fix whatever broken. A few macros are provided to be used in for the convenience: ignore-field! Eliminates the from the structure . fix-field! ... Binds a variable 'field' to an instance of class that represents the field information of the structure, then evaluates .... You can change the slot values of the instance to fix whatever broken. add-field! ... Creates a new instance for a field, and adds it to the current structure. add-mixin! ... Adds classes specified by to the direct superclass of the current structure. gauche-gtk-0.6+git20160927/src/exclude000066400000000000000000000013631300401456300171520ustar00rootroot00000000000000-*-outline-*- gtkfilesystem.h gtkimmodule.h !! gtktext.h #ifdef GTK_ENABLE_BROKEN gtktext.h ... fixme: i had this before! gtktextlayout.h fixme: i had this before! #ifndef GTK_TEXT_USE_INTERNAL_UNSUPPORTED_API #error "You are not supposed to be including this file; the equivalent public API is in gtktextview.h" #endif just take /usr/include/gtk-2.0/gtk/gtk.h ? w/o gdk/gdk.h - gtktoolbar.h was twice !??? - grep '#include //' > GTKFILES set #ifdef GTK_ENABLE_BROKEN gtktree! grep GTK_ENABLE_BROKEN *.h gtkversion.h gtkmodules.h * I had to add: ** gtktextmark.h ** gtk-text-child-anchor gtktextchild.h gtktexttag.h gtktextiter.h gtktreesortable.h gauche-gtk-0.6+git20160927/src/gauche-gdklib.stub000066400000000000000000000115531300401456300211650ustar00rootroot00000000000000;;; ;;; gauche-gtklib.stub ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gauche-gdklib.stub,v 1.5 2007/01/13 01:36:31 maruska Exp $ ;;; ;; some auxiliary gdk stuff (include "gtk-lib.types") "#include \"gauche-gtk.h\"" ;; Point vector ----------------------------------------- (define-cproc make-gdk-point-vector (length::) "SCM_RETURN(Scm_MakeGdkPointVector(NULL, length));") (define-cproc gdk-point-vector-length (v::) "SCM_RETURN(SCM_MAKE_INT(v->size));") (define-cproc gdk-point-vector-ref (v:: i:: &optional fallback) "if (i < 0 || i >= v->size) { if (SCM_UNBOUNDP(fallback)) { Scm_Error(\"index out of range: %d\", i); SCM_RETURN(SCM_UNDEFINED); } else { SCM_RETURN(fallback); } } else { SCM_RETURN(SCM_MAKE_GDK_POINT(&(v->elements[i]))); }" (setter gdk-point-vector-set!)) (define-cproc gdk-point-vector-set! (v:: i:: value::) "if (i < 0 || i >= v->size) { Scm_Error(\"index out of range: %d\", i); } else { v->elements[i] = *value; } SCM_RETURN(SCM_UNDEFINED);") ;; Segment vector --------------------------------------- (define-cproc make-gdk-segment-vector (length::) "SCM_RETURN(Scm_MakeGdkSegmentVector(NULL, length));") (define-cproc gdk-segment-vector-length (v::) "SCM_RETURN(SCM_MAKE_INT(v->size));") (define-cproc gdk-segment-vector-ref (v:: i:: &optional fallback) "if (i < 0 || i >= v->size) { if (SCM_UNBOUNDP(fallback)) { Scm_Error(\"index out of range: %d\", i); SCM_RETURN(SCM_UNDEFINED); } else { SCM_RETURN(fallback); } } else { SCM_RETURN(SCM_MAKE_GDK_SEGMENT(&(v->elements[i]))); }" (setter gdk-segment-vector-set!)) (define-cproc gdk-segment-vector-set! (v:: i:: value::) "if (i < 0 || i >= v->size) { Scm_Error(\"index out of range: %d\", i); } else { v->elements[i] = *value; } SCM_RETURN(SCM_UNDEFINED);") ;; Rectangle vector --------------------------------------- (define-cproc make-gdk-rectangle-vector (length::) "SCM_RETURN(Scm_MakeGdkRectangleVector(NULL, length));") (define-cproc gdk-rectangle-vector-length (v::) "SCM_RETURN(SCM_MAKE_INT(v->size));") (define-cproc gdk-rectangle-vector-ref (v:: i:: &optional fallback) "if (i < 0 || i >= v->size) { if (SCM_UNBOUNDP(fallback)) { Scm_Error(\"index out of range: %d\", i); SCM_RETURN(SCM_UNDEFINED); } else { SCM_RETURN(fallback); } } else { SCM_RETURN(SCM_MAKE_GDK_RECTANGLE(&(v->elements[i]))); }" (setter gdk-rectangle-vector-set!)) (define-cproc gdk-rectangle-vector-set! (v:: i:: value::) "if (i < 0 || i >= v->size) { Scm_Error(\"index out of range: %d\", i); } else { v->elements[i] = *value; } SCM_RETURN(SCM_UNDEFINED);") ;; Color vector ------------------------------------------------ (define-cproc make-gdk-color-vector (length::) "SCM_RETURN(Scm_MakeGdkColorVector(NULL, length));") (define-cproc gdk-color-vector-length (v::) "SCM_RETURN(SCM_MAKE_INT(v->size));") (define-cproc gdk-color-vector-ref (v:: i:: &optional fallback) "if (i < 0 || i >= v->size) { if (SCM_UNBOUNDP(fallback)) { Scm_Error(\"index out of range: %d\", i); SCM_RETURN(SCM_UNDEFINED); } else { SCM_RETURN(fallback); } } else { SCM_RETURN(SCM_MAKE_GDK_COLOR(&(v->elements[i]))); }" (setter gdk-color-vector-set!)) (define-cproc gdk-color-vector-set! (v:: i:: value::) "if (i < 0 || i >= v->size) { Scm_Error(\"index out of range: %d\", i); } else { v->elements[i] = *value; } SCM_RETURN(SCM_UNDEFINED);") ;; keysyms. ;"#include " ;(include "gdk-keysyms.stub") ;; Local variables: ;; mode: scheme ;; end: gauche-gtk-0.6+git20160927/src/gauche-glib.stub000066400000000000000000000222661300401456300206510ustar00rootroot00000000000000;;; ;;; gauche-glib.stub ;;; ;;; Copyright(C) 2002 by Shiro Kawai (shiro@acm.org) ;;; ;;; Permission to use, copy, modify, distribute this software and ;;; accompanying documentation for any purpose is hereby granted, ;;; provided that existing copyright notices are retained in all ;;; copies and that this notice is included verbatim in all ;;; distributions. ;;; This software is provided as is, without express or implied ;;; warranty. In no circumstances the author(s) shall be liable ;;; for any damages arising out of the use of this software. ;;; ;;; $Id: gauche-glib.stub,v 1.6 2007/01/13 01:36:31 maruska Exp $ ;;; (include "gtk-lib.types") "#include \"gauche-gtk.h\"" ;; Defines some basic Glib stubs ;;================================================================ ;; g_object interface ;; ;; For these procs, we can't say instance:: ;; since we need to pass ScmGObject* instead of unboxed GObject. (define-cproc g-object-get-data (instance key &optional fallback) "if (!SCM_GOBJECT_P(instance)) Scm_Error(\" required, but got %S\", instance); SCM_RETURN(Scm_GObjectGetData(SCM_GOBJECT(instance), key, fallback));") (define-cproc g-object-set-data (instance key &optional data) "if (!SCM_GOBJECT_P(instance)) Scm_Error(\" required, but got %S\", instance); SCM_RETURN(Scm_GObjectSetData(SCM_GOBJECT(instance), key, data));") (define-cproc g-object-unref (instance) "if (!SCM_GOBJECT_P(instance)) Scm_Error(\" required, but got %S\", instance); Scm_GObjectUnref(SCM_GOBJECT(instance)); SCM_RETURN(SCM_UNDEFINED);") (define-cproc g-object-unreferenced? (instance) "if (SCM_GOBJECT_P(instance) && SCM_GOBJECT(instance)->gobject == NULL) SCM_RETURN(SCM_TRUE); else SCM_RETURN(SCM_FALSE);") ;; Get/set property ;;;; mmc: the property can be void. So, we have to initialize the gvalue (w/ the right type). (define-cproc g-object-get-property (instance:: key::) "GType gtype = Scm_ClassToGtkType(SCM_CLASS_OF(instance_scm)); gpointer gclass; gclass = g_type_class_ref(gtype); GParamSpec* spec = g_object_class_find_property (gclass, key); GValue ret = {0}; g_value_init (&ret, spec->value_type); g_type_class_unref(gclass); g_object_get_property(instance, key, &ret); SCM_RETURN(Scm_UnboxGValue(&ret));") (define-cproc g-object-set-property (instance:: key:: value) "GValue gv; g_object_set_property(instance, Scm_GetStringConst(key), Scm_ObjToGValue(value, &gv)); SCM_RETURN(SCM_UNDEFINED);") ;; GType gtype = Scm_ClassToGtkType(SCM_CLASS_OF(instance_scm)); ;; gpointer gclass; ;; gclass = g_type_class_ref(gtype); (define-cproc g-object-class-find-property (type:: ;; instance:: key::) " GType gtype = Scm_ClassToGtkType(type); if (gtype == G_TYPE_INVALID) { Scm_Error(\"given class doesn't correspond to an GObject class: %S\", type); } gpointer gclass; gclass = g_type_class_ref(gtype); GParamSpec* gs = g_object_class_find_property(gclass, key); g_type_class_unref(gclass); if (gs == NULL) return SCM_FALSE; ScmObj flags = SCM_MAKE_INT(gs->flags); #if 0 /* *** glibc detected *** /usr/bin/gosh: munmap_chunk(): invalid pointer: 0x0846f318 *** */ g_free(gs); #endif /* Scm_MakeInteger */ return flags;") ;; todo: gtype! owner? #;(define-enum G_PARAM_READABLE G_PARAM_WRITABLE G_PARAM_CONSTRUCT G_PARAM_CONSTRUCT_ONLY G_PARAM_LAX_VALIDATION G_PARAM_STATIC_NAME G_PARAM_STATIC_NICK G_PARAM_STATIC_BLURB ) ;;================================================================ ;; g_signal interface ;; (define-cproc g-signal-connect (instance:: detailed-signal:: handler:: &optional (afterp #f)) "gulong r; r = g_signal_connect_closure((gpointer)instance, Scm_GetStringConst(detailed_signal), Scm_MakeGClosure_mmc(handler, detailed_signal_scm), /*detailed_signal*/ SCM_BOOL_VALUE(afterp)); SCM_RETURN(Scm_MakeIntegerFromUI(r));") (define-cproc g-signal-handler-disconnect (object:: id::) :: g_signal_handler_disconnect) (define-cproc g-signal-handler-block (object:: id::) :: g_signal_handler_block) (define-cproc g-signal-handler-unblock (object:: id::) :: g_signal_handler_unblock) ;; NB: no block_by_func or unblock_by_func. ;;================================================================ ;; g_timer interface ;; (define-cclass "ScmGTimer*" "Scm_GTimerClass" () ()) (define-cproc g-timer-new () :: g_timer_new) (define-cproc g-timer-start (timer::) :: g_timer_start) (define-cproc g-timer-stop (timer::) :: g_timer_stop) (define-cproc g-timer-elapsed (timer::) :: (result (g_timer_elapsed timer NULL))) (define-cproc g-timer-reset (timer::) :: g_timer_reset) ;; Local variables: ;; mode: scheme ;; end: (define-type "GSignalQuery*" "comment" "SCM_G_SIGNAL_QUERY_P" "SCM_G_SIGNAL_QUERY" "Scm_Make_GSignalQuery") (define-cclass "ScmGSignalQuery" "Scm_GSignalQuery_Class" () ;cpa ( ; must not be changed! (signal-id :type :setter #f) ; c-name ? (signal-name :type ;; ok: :getter "SCM_RETURN(SCM_OBJ(((ScmGSignalQuery*)OBJARG)->name));" ;fixme! :setter #f ) ;:setter #f ;; fixme! (itype ;:type ;; :accessor :getter "SCM_RETURN(SCM_OBJ(Scm_GtkTypeToScmClass(obj->itype)));" :setter #f) (signal-flags :type ;enum! :setter #f) (return-type ;:type :getter "SCM_RETURN(SCM_OBJ(Scm_GtkTypeToScmClass(obj->return_type)));" :setter #f ) (n-params :type :setter #f ) ;(param-types :type ) ;array ! ) ;(allocator (c "new_pg_result")) ;(printer (c "pg_result_print")) ) ;; (define-cproc gsignal-nth-param-type (gsq:: n::) " if (n >= gsq->n_params) Scm_Error(\"out-of-bound %d, max %d\", n, gsq->n_params); SCM_RETURN (SCM_OBJ(Scm_GtkTypeToScmClass(gsq->param_types[n]))); ") ;; g-signal-query is almost the name of the type, also! (define-cproc g-signal-query (signal-id::) " /*I might keep it inline....*/ GSignalQuery* g = (GSignalQuery*) SCM_MALLOC(sizeof(GSignalQuery)); /* cannot allocate it as _ATOMIC. ->name! */ g_signal_query(signal_id,g); #if 0 if (g->signal_name) Scm_Warn(\"the signal's name is %s\", g->signal_name); #endif SCM_RETURN (SCM_OBJ(Scm_Make_GSignalQuery(g))); ") (define-cproc g-object-class-list-properties (type::) "GType gtype = Scm_ClassToGtkType(type); if (gtype == G_TYPE_INVALID) { Scm_Error(\"given class doesn't correspond to an GObject class: %S\", type); } /* GTypeClass */ GObjectClass* gclass = g_type_class_ref(gtype); guint n; GParamSpec* gs = g_object_class_list_properties(gclass,&n); ScmObj sn = SCM_MAKE_INT(n); g_type_class_unref(gclass); return sn;") (define-cproc g-signal-lookup (name:: type::) "GType gtype = Scm_ClassToGtkType(type); if (gtype == G_TYPE_INVALID) { Scm_Error(\"given class doesn't correspond to an GObject class: %S\", type); } int sig= g_signal_lookup(name, gtype); #if 0 /* if (sig == 0) ? */ Scm_Warn(\"g-signal-lookup: %s x %s -> %d\", g_type_name(gtype), name, sig); #endif SCM_RETURN (Scm_MakeInteger(sig));" ) (define-cproc g-signal-emit (destination signal-id:: detail:: params) ; type:: "return Scm_g_signal_emit(destination, signal_id, detail, params);") (define-cproc g-signal-list-ids (type::) ;destination "GType gtype = Scm_ClassToGtkType(type); if (gtype == G_TYPE_INVALID) { Scm_Error(\"given class doesn't correspond to an GObject class: %S\", type); }; /* Get the GType: I could accept both classes, both instances ? */ guint n; guint* result = g_signal_list_ids(gtype, &n); ScmVector* vec = SCM_VECTOR(Scm_MakeVector(n,SCM_FALSE)); int i; for(i = 0; i< n; i++) Scm_VectorSet(vec, i, Scm_MakeInteger(result[i])); /* make a vector? */ SCM_RETURN(SCM_OBJ(vec)); ") ;; Useless! and broken! ;; (define-cproc make-gdk-event (type::) ;fixme: or even class! ;; " ;; GdkEvent* ge = gdk_event_new(type); ;; if (! ge) ;; Scm_Error(\"%d is not a valide GdkEventType\", type); ;; ScmObj ev = Scm_MakeGdkEvent(ge); /* Uses gdk_event_copy !! */ ;; g_free(ge); ;; SCM_RETURN(ev); ;; ") (define-cproc dump-referenced-gobjects () :: dump_referenced_gobjects) (define-cproc gtk-trace-references (value::) :: (set! gtk_trace_references value)) gauche-gtk-0.6+git20160927/src/gauche-gtk.c000066400000000000000000001725161300401456300177720ustar00rootroot00000000000000/* * gauche-gtk.h - Gauche+Gtk extension * * Copyright(C) 2002-2004 by Shiro Kawai (shiro@acm.org) * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in all * distributions. * This software is provided as is, without express or implied * warranty. In no circumstances the author(s) shall be liable * for any damages arising out of the use of this software. * * $Id: gauche-gtk.c,v 1.52 2007/01/13 01:36:31 maruska Exp $ */ #include "gauche-gtk.h" #include /* SCM_VM_MAX_VALUES */ /*=============================================================== * GObject <-> ScmObj mapping */ /* NB: it is not trivial to keep reference-counting Gtk memory allocation and mark-sweep GC happily together. The naive method (increment Gtk refcount when Scheme obtains the pointer to it, and decrement it when Scheme objects are garbage-collected) has a problem: We need to protect Scheme pointers passed to Gtk object. Gtk has a callback when it releases the passed pointer, so we can register the Scheme pointer to a global table to protect from being GC'ed, and remove it in the Gtk's callback. However, if the reference consists a cycle, i.e. the Scheme object passed to Gtk has a reference to other Scheme objects which eventually points back to the Gtk object, then the Gtk object's refcount never go down to zero, and whole structure will never be reclaimed. This issue has been discussed in gtk mailing list. http://mail.gnome.org/archives/gtk-list/1998-April/msg00525.html Vollmer Marius told how Guile-gtk handled it, which seems the best approximation strategy so far I've seen: http://mail.gnome.org/archives/gtk-list/1998-April/msg00596.html It may be possible that I hook Boehm GC (by providing user-defined mark_proc) to implement Vollmer's strategy, but I haven't understood innards of Boehm GC enough yet. */ static struct { ScmHashTable *protected; /* Table of Scheme objects that is passed to GTk, to protect them from GC'ed. The key is the object itself, and the value is a # of times the object is protected. */ ScmInternalMutex protected_mutex; ScmHashTable *typemap; /* Map ScmClass to GType. It is rarely used, but needed in some API that handles meta information (e.g. liststore) */ ScmInternalMutex typemap_mutex; GQuark scmclass_key; /* A Quark used in the property list of GType to keep its associated ScmClass. */ GQuark scmobj_key; /* A Quark used in the property list of GObject to point back Scheme object. */ } gtkdata = { /* Initialize the first item so that the structure is placed in the data area. */ NULL }; /* * Type mapping */ /* In order to 'box' given GObject in a Scheme object, we need to know * the Scheme class corresponding to the given GObject type. GObject * type system has a sort of property list (called qdata), so we use * it to keep the type's corresponding ScmClass. * Scm_GtkRegisterClass establishes the bidirectional link between * GType and ScmClass. It is called from initialization routine. */ typedef struct ScmGTypeRec { SCM_HEADER; GType gtype; } ScmGType; /* mmc: this is for debugging. I keep a weak(?) hash of all Gobjects. */ ScmHashTable* referenced_gobjects; static SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_GTypeClass, NULL); /* mmc: it is fundamental that gtkdata.`typemap_mutex' can be locked more times by the same thread! fixme! */ void Scm_GtkRegisterClass(GType type, ScmClass *klass) { ScmGType *gtype = SCM_NEW(ScmGType); SCM_SET_CLASS(gtype, &Scm_GTypeClass); gtype->gtype = type; #if DEBUG Scm_Warn("%s: %s\n", __FUNCTION__, g_type_name(type)); #endif g_type_set_qdata(type, gtkdata.scmclass_key, (gpointer)klass); /* mmc: why do we have to lock it? Are hashes thread-safe? */ (void)SCM_INTERNAL_MUTEX_LOCK(gtkdata.typemap_mutex); Scm_HashTablePut(gtkdata.typemap, SCM_OBJ(klass), SCM_OBJ(gtype)); (void)SCM_INTERNAL_MUTEX_UNLOCK(gtkdata.typemap_mutex); } /* mmc: so this doesn't work for base types ??? */ ScmClass *Scm_GtkTypeToScmClass(GType type) { ScmClass *c = NULL; GType t = type; /* Gtk API may return an object of private subtype of the published type, so if we don't find the corresponding ScmClass, need to look for its ancestors. */ for (;;) { c = (ScmClass*)g_type_get_qdata(t, gtkdata.scmclass_key); if (c) return c; t = g_type_parent(t); if (t == 0) { const char *name = g_type_name(type); Scm_Warn("Unknown GType %x(%s); GObject assumed", type, name? name : "noname"); return SCM_CLASS_GOBJECT; } } /*NOTREACHED*/ } GType Scm_ClassToGtkType(ScmClass *klass) { ScmHashEntry *e; (void)SCM_INTERNAL_MUTEX_LOCK(gtkdata.typemap_mutex); e = Scm_HashTableGet(gtkdata.typemap, SCM_OBJ(klass)); (void)SCM_INTERNAL_MUTEX_UNLOCK(gtkdata.typemap_mutex); if (!e) return G_TYPE_INVALID; else return ((ScmGType*)(e->value))->gtype; } /* mmc: types must be allocated */ int Scm_ClassListToGtkTypeList(ScmObj klasses, GType *types) { int len, i = 0; ScmObj k = SCM_NIL; GType gt; if ((len = Scm_Length(klasses)) > 0) { ScmObj sp; SCM_FOR_EACH(sp, klasses) { k = SCM_CAR(sp); if (!Scm_TypeP(k, SCM_CLASS_CLASS)) goto noklass; gt = Scm_ClassToGtkType(SCM_CLASS(k)); if (gt == G_TYPE_INVALID) goto notype; types[i++] = gt; } return i; } else if (SCM_VECTORP(klasses)) { ScmObj *sp = SCM_VECTOR_ELEMENTS(klasses); len = SCM_VECTOR_SIZE(klasses); for (i=0; i expected, but got %S", klasses); } noklass: Scm_Error(" required, but got %S", k); notype: Scm_Error("Class %S doesn't have corresponding Gtk type", k); return -1; /* dummy */ } /* pre-registered primitive types */ static struct predef_type { ScmClass *scmklass; GType gtype; } predef_types[] = { { SCM_CLASS_BOOL, G_TYPE_BOOLEAN }, { SCM_CLASS_CHAR, G_TYPE_CHAR }, { SCM_CLASS_INTEGER, G_TYPE_INT }, { SCM_CLASS_REAL, G_TYPE_DOUBLE }, { SCM_CLASS_STRING, G_TYPE_STRING }, { NULL } }; static void typemap_initialize(ScmHashTable *table) { /* mmc: no reverse mapping from q_data ? */ struct predef_type *ptype = predef_types; #if DEBUG Scm_Warn("%s: %d\n", __FUNCTION__, sizeof(predef_types)/sizeof(predef_types[0])); /* array_size */ #endif for (; ptype->scmklass; ptype++) { #if 1 Scm_GtkRegisterClass(ptype->gtype, ptype->scmklass); #else ScmGType *g = SCM_NEW(ScmGType); SCM_SET_CLASS(g, &Scm_GTypeClass); g->gtype = ptype->gtype; Scm_HashTablePut(table, SCM_OBJ(ptype->scmklass), SCM_OBJ(g)); #endif /* fixme: This should call void Scm_GtkRegisterClass(GType type, ScmClass *klass) * And Also the events! */ } } /* * GObject */ /*static void gobject_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)*/ static int gobject_compare(ScmObj x, ScmObj y, int equalp) { #if DEBUG Scm_Warn("%s:\n", __FUNCTION__); Scm_Warn("%s: %u %u\n", __FUNCTION__, SCM_GOBJECT_OBJECT(x), SCM_GOBJECT_OBJECT(y)); #endif if (equalp) { return (SCM_GOBJECT_OBJECT(x) == SCM_GOBJECT_OBJECT(y))? 0 : -1; } else { Scm_Error("can't order GObject %S and %S", x, y); return 0; } } /* signal handler for "destroy" */ static void gobject_destroy(GtkObject *gobj, void *data) { #if DEBUG Scm_Warn("%s:\n", __FUNCTION__); #endif ScmGObject *g = (ScmGObject*)data; Scm_GObjectUnref(g); } /* mmc: manually creating the class (stubs do it usually) */ ScmClass *Scm_GObjectCPL[] = { SCM_CLASS_STATIC_PTR(Scm_GObjectClass), SCM_CLASS_STATIC_PTR(Scm_TopClass), NULL }; SCM_DEFINE_BASE_CLASS(Scm_GObjectClass, ScmGObject, NULL, gobject_compare, NULL, Scm_GtkObjectAllocate, Scm_GObjectCPL+1); /* mmc: why + 1 ??? Only top !*/ #if 0 /* for now, we rely on explicit deallocation */ static void gobject_finalize(ScmObj obj, void *data) { ScmGObject *g = SCM_GOBJECT(obj); g_object_set_qdata(SCM_GOBJECT_OBJECT(g), gtkdata.scmobj_key, NULL); g_object_unref(SCM_GOBJECT_OBJECT(g)); } #endif void dump_referenced_gobjects() { ScmHashIter iter; Scm_HashIterInit(&iter, SCM_HASH_TABLE_CORE(referenced_gobjects)); ScmDictEntry* e; GObject* go; Scm_Warn("%s", __FUNCTION__); while (e = Scm_HashIterNext(&iter)) { go = G_OBJECT(SCM_DICT_KEY(e)); Scm_Warn("\t%s: %d", /* (! klass || !klass->name)?"": Scm_GetString(SCM_STRING(klass->name)), */ g_type_name(G_OBJECT_TYPE(go)), go->ref_count); } Scm_Warn("END %s", __FUNCTION__); } int gtk_trace_references = 0; /* Internal routine to create a Scheme wrapper for gobject. */ static ScmGObject *make_gobject(ScmClass *klass, GObject *gobj) { ScmGObject *g; SCM_ASSERT(Scm_SubtypeP(klass, SCM_CLASS_GOBJECT)); /* in gauche-gtk.h */ g = SCM_ALLOCATE(ScmGObject, klass); SCM_SET_CLASS(g, klass); g->gobject = gobj; #if DEBUG Scm_Warn("%s: %u\n", __FUNCTION__, gobj); #endif g->data = SCM_NIL; Scm_GtkProtect(SCM_OBJ(g)); g_object_set_qdata_full(gobj, gtkdata.scmobj_key, (gpointer)g, (GDestroyNotify)Scm_GtkUnprotect); #if 0 /* for now, we rely on explicit deallocation */ Scm_RegisterFinalizer(SCM_OBJ(g), gobject_finalize, NULL); #endif if (g_type_is_a(G_OBJECT_TYPE(gobj), GTK_TYPE_OBJECT)) { #if 0 Scm_Printf(SCM_VM_CURRENT_ERROR_PORT(Scm_VM()),"g_object_ref\n"); #endif g_object_ref(gobj); /* Take floating reference */ gtk_object_sink(GTK_OBJECT(gobj)); /* mmc: g->ref_count = 1; */ /* mmc: */ /* Scm_HashTablePutRaw */ Scm_HashTablePut(referenced_gobjects, SCM_OBJ(gobj), SCM_OBJ(gobj)); if (gtk_trace_references) Scm_Warn("%s: %s refcount is %d after ref & sink.\n", __FUNCTION__, /* (! klass || !klass->name)?"": Scm_GetString(SCM_STRING(klass->name)), */ g_type_name(G_OBJECT_TYPE(gobj)), gobj->ref_count); /* g_type_name() */ /* Drop the reference upon destruction. */ g->destroy_handler = g_signal_connect_after(GTK_OBJECT(gobj), "destroy", /* _after */ (GCallback)gobject_destroy, (void*)g); } else g->destroy_handler = 0; return g; } /* 'Box' a pointer to GObject. */ ScmObj Scm_MakeGObject(void *obj) { ScmClass *klass; ScmGObject *g; GObject *gobj; /* Allow obj == NULL */ if (obj == NULL) return SCM_FALSE; gobj = G_OBJECT(obj); /* First, see if this GObject already has corresponding ScmObj */ g = (ScmGObject*)g_object_get_qdata(gobj, gtkdata.scmobj_key); if (g == NULL) { #if DEBUG Scm_Warn("%s: we have to create a new ScmGObject: %u\n", __FUNCTION__, gobj); #endif /* Creates ScmGObject */ klass = Scm_GtkTypeToScmClass(G_OBJECT_TYPE(gobj)); g = make_gobject(klass, gobj); } return SCM_OBJ(g); } /* Common allocator of GtkObject. Should be used only from gtk*.stub. */ ScmObj Scm_GtkObjectAllocate(ScmClass *klass, ScmObj initargs) { ScmClass **k = klass->cpa; GType gbase = G_TYPE_INVALID, t; /* Find out which GtkObject should be instantiated, and also there's no conflicting GtkType in CPL. */ t = Scm_ClassToGtkType(klass); if (t != G_TYPE_INVALID) gbase = t; for (; *k; k++) { t = Scm_ClassToGtkType(*k); if (t != G_TYPE_INVALID) { if (gbase == G_TYPE_INVALID) { gbase = t; } else { if (!g_type_is_a(gbase, t)) { const gchar *gn = g_type_name(gbase); const gchar *tn = g_type_name(t); Scm_Error("class precedence list of %S contains conflicting GtkObject types: %s and %s", klass, (gn? gn : "?"), (tn? tn : "?")); } } } } if (gbase == G_TYPE_INVALID) { Scm_Error("can't instantiate object of class %S", klass); } return SCM_OBJ(make_gobject(klass, g_object_new(gbase, NULL))); } /* Protect and unprotect the Scheme object passed to Gtk */ void Scm_GtkProtect(ScmObj data) { ScmHashEntry *e; int count; (void)SCM_INTERNAL_MUTEX_LOCK(gtkdata.protected_mutex); e = Scm_HashTableAdd(gtkdata.protected, data, SCM_MAKE_INT(0)); count = SCM_INT_VALUE(e->value) + 1; e->value = SCM_MAKE_INT(count); (void)SCM_INTERNAL_MUTEX_UNLOCK(gtkdata.protected_mutex); } void Scm_GtkUnprotect(gpointer data) { ScmHashEntry *e; int count; if (!data) return; (void)SCM_INTERNAL_MUTEX_LOCK(gtkdata.protected_mutex); e = Scm_HashTableGet(gtkdata.protected, SCM_OBJ(data)); if (e) { count = SCM_INT_VALUE(e->value) - 1; if (count == 0) { Scm_HashTableDelete(gtkdata.protected, SCM_OBJ(data)); } else { e->value = SCM_MAKE_INT(count); } } (void)SCM_INTERNAL_MUTEX_UNLOCK(gtkdata.protected_mutex); } /* Explicitly unreference GObject. This is necessary to break the cyclic reference until the customized mark procedure is implemented (see the discussion above). Once unreferenced, gobject field becomes NULL, even if the pointed GObject has more than one reference. The idea is that the Scheme object here will be garbage-collected soon. */ void Scm_GObjectUnref(ScmGObject *gobj) { if (gobj->destroy_handler && gobj->gobject){ /* If the signal is being emitted? */ /* I might hint it here: */ g_signal_handler_disconnect(gobj->gobject, gobj->destroy_handler); gobj->destroy_handler = 0; } if (gobj->gobject) { GObject *g = gobj->gobject; Scm_HashTableDelete(referenced_gobjects, SCM_OBJ(g)); if (gtk_trace_references) Scm_Warn("%s: refcount is %d before our unref.\n", __FUNCTION__, g->ref_count); g_object_set_qdata(g, gtkdata.scmobj_key, NULL); gobj->gobject = NULL; g_object_unref(g); } } /* Checks if GObject is not unreferenced */ GObject *Scm_GObjectCheck(ScmGObject *gobj) { if (!gobj->gobject) { Scm_Error("GObject has been unreferenced from %S", gobj); } return gobj->gobject; } /* Scheme-world GObject data & properties */ ScmObj Scm_GObjectGetData(ScmGObject *gobj, ScmObj key, ScmObj fallback) { ScmObj p = Scm_Assq(key, gobj->data); /* was ScmObj p = Scm_Assoc(key, gobj->data, SCM_CMP_EQUAL); */ if (SCM_PAIRP(p)) return SCM_CDR(p); if (SCM_UNBOUNDP(fallback)) Scm_Error("GObject %S doesn't have a property for the key %S", gobj, key); return fallback; } ScmObj Scm_GObjectSetData(ScmGObject *gobj, ScmObj key, ScmObj data) { if (SCM_UNBOUNDP(data)) { gobj->data = Scm_AssocDeleteX(key, gobj->data, SCM_CMP_EQ); } else { ScmObj p = Scm_Assq(key, gobj->data); if (SCM_PAIRP(p)) SCM_SET_CDR(p, data); else { gobj->data = Scm_Acons(key, data, gobj->data); } } return SCM_UNDEFINED; } #if 0 static const char *get_key(ScmObj key) { if (SCM_STRINGP(key)) return Scm_GetStringConst(SCM_STRING(key)); if (SCM_SYMBOLP(key)) return Scm_GetStringConst(SCM_SYMBOL_NAME(key)); if (SCM_IDENTIFIERP(key)) return Scm_GetStringConst(SCM_SYMBOL_NAME(SCM_IDENTIFIER(key)->name)); Scm_Error("property key must be a string or a symbol, but got %S", key); return ""; /* dummy */ } #endif /*=============================================================== * Callbacks */ /* Issues: * * * Error handling and non-local exit in callbacked Scheme program: * The Scheme closure is effectively invoked inside with-error-handler * so that the errors are captured and handled (right now by * Scm_ReportError) before returning to C. * Outbound continuation invocation, that is, the invocation of a * continuation captured below the Gtk loop, is more problematic. * It can happen, for example, if the user builds his/her own error * handling mechanism using call/cc. * If the program 'restarts', that is, re-enters gtk-main again, * it would be a problem. It is OK if the program just exits. * We won't know which is the case here, so we assume the user * knows what he/she is doing. * * * Argument marshalling. Gtk/Glib callback mechanism provide * complete type information of arguments & return value, so what * I need to do is just map those arguments to Scheme values. * The old Gtk used GtkArg structure for this purpose, but the new * Gtk uses Glib's GValue mechanism. There are still some callbacks * in Gtk that uses GtkArg, so we need to support both. */ /* We wrap callback with error handler. see gtk.scm for the actual definition of %gtk-call-callback. */ static ScmObj call_callback(ScmObj proc, ScmObj args) { static ScmObj call_callback_proc = SCM_UNDEFINED; SCM_BIND_PROC(call_callback_proc, "%gtk-call-callback", Scm_FindModule(SCM_SYMBOL(SCM_INTERN("gtk")), 0)); return Scm_ApplyRec2(call_callback_proc, SCM_OBJ(proc), args); } /* Argument & return value marshalling - GValue version */ ScmObj Scm_UnboxGValue(const GValue *gv) { GType gt = G_VALUE_TYPE(gv); switch (G_TYPE_FUNDAMENTAL(gt)) { case G_TYPE_CHAR: return SCM_MAKE_INT((int)g_value_get_char(gv)); case G_TYPE_UCHAR: return SCM_MAKE_INT((int)g_value_get_uchar(gv)); case G_TYPE_BOOLEAN: return SCM_MAKE_BOOL(g_value_get_boolean(gv)); case G_TYPE_INT: return Scm_MakeInteger(g_value_get_int(gv)); case G_TYPE_UINT: return Scm_MakeIntegerU(g_value_get_uint(gv)); case G_TYPE_LONG: return Scm_MakeInteger(g_value_get_long(gv)); case G_TYPE_ULONG: return Scm_MakeInteger(g_value_get_ulong(gv)); case G_TYPE_FLOAT: return Scm_MakeFlonum((double)g_value_get_float(gv)); case G_TYPE_DOUBLE:return Scm_MakeFlonum(g_value_get_double(gv)); case G_TYPE_STRING: return SCM_MAKE_STR_COPYING(g_value_get_string(gv)); case G_TYPE_OBJECT: return Scm_MakeGObject(G_OBJECT(g_value_get_object(gv))); /* how many references ? */ case G_TYPE_POINTER: { Scm_Warn("got G_TYPE_POINTER (really a %s)", g_type_name(gt)); return SCM_UNDEFINED; } /* enum G_TYPE_ENUM G_VALUE_HOLDS_ENUM * *gint g_value_get_enum (const [823]GValue *value); * !! */ default: if (gt == GTK_TYPE_REQUISITION) { return SCM_MAKE_GTK_REQUISITION((GtkRequisition*)g_value_get_boxed(gv)); } if (gt == GDK_TYPE_RECTANGLE) { return SCM_MAKE_GDK_RECTANGLE((GdkRectangle*)g_value_get_boxed(gv)); } if (G_VALUE_HOLDS_ENUM(gv)) return Scm_MakeInteger(g_value_get_enum(gv)); /* I'm not sure this is a right thing, but for now...*/ if (gt == GDK_TYPE_EVENT) { return Scm_MakeGdkEvent((GdkEvent*)g_value_get_boxed(gv)); } if (g_type_is_a (gt, G_TYPE_FLAGS)) { return Scm_MakeInteger(g_value_get_flags(gv)); } if (gt == gtk_tree_path_get_type()) { return SCM_MAKE_GTK_TREE_PATH((GtkTreePath*)g_value_get_boxed(gv)); } /* GtkSelectionData */ Scm_Warn("cannot convert a GValue of type %s to a Scheme object (%d)", g_type_name(gt), G_TYPE_FUNDAMENTAL(gt)); return SCM_UNDEFINED; } } /* mmc: gvalue determines the type. scheme value -> gv ?? */ void Scm_BoxGValue(GValue *gv, ScmObj sv) { GType gt = G_VALUE_TYPE(gv); switch (G_TYPE_FUNDAMENTAL(gt)) { case G_TYPE_INVALID: /* this happens in some callbacks. I assume the receiver doesn't need the return value. */ return; case G_TYPE_CHAR: { int v; if (SCM_INTP(sv)) v = SCM_INT_VALUE(sv); else if (SCM_CHARP(sv)) v = SCM_CHAR_VALUE(sv); else goto err; if (v < -128 || v > 127) goto err; g_value_set_char(gv, (gchar)v); return; } case G_TYPE_UCHAR: { int v; if (SCM_INTP(sv)) v = SCM_INT_VALUE(sv); else if (SCM_CHARP(sv)) v = SCM_CHAR_VALUE(sv); else goto err; if (v < 0 || v > 255) goto err; g_value_set_uchar(gv, (guchar)v); return; } case G_TYPE_BOOLEAN: { g_value_set_boolean(gv, SCM_BOOL_VALUE(sv)); return; } case G_TYPE_INT: { if (!SCM_EXACTP(sv)) goto err; g_value_set_int(gv, Scm_GetInteger(sv)); return; } case G_TYPE_UINT: { if (!SCM_EXACTP(sv)) goto err; g_value_set_uint(gv, Scm_GetIntegerU(sv)); return; } case G_TYPE_LONG: { if (!SCM_EXACTP(sv)) goto err; g_value_set_long(gv, Scm_GetInteger(sv)); return; } case G_TYPE_ULONG: { if (!SCM_EXACTP(sv)) goto err; g_value_set_ulong(gv, Scm_GetIntegerU(sv)); return; } case G_TYPE_FLOAT: { if (!SCM_REALP(sv)) goto err; g_value_set_float(gv, (gfloat)Scm_GetDouble(sv)); return; } case G_TYPE_DOUBLE: { if (!SCM_REALP(sv)) goto err; g_value_set_double(gv, Scm_GetDouble(sv)); return; } case G_TYPE_STRING: { if (!SCM_STRINGP(sv)) goto err; g_value_set_string(gv, Scm_GetStringConst(SCM_STRING(sv))); return; } case G_TYPE_OBJECT: { if (!Scm_TypeP(sv, SCM_CLASS_GOBJECT)) goto err; g_value_set_object(gv, SCM_GOBJECT_OBJECT(sv)); return; } default: if (g_type_is_a(gt, G_TYPE_ENUM)) { g_value_set_enum(gv, Scm_GetInteger(sv)); return; } err: Scm_Error("cannot convert a Scheme object %S to a GValue of type %s", sv, g_type_name(gt)); } } /* Like BoxGValue, except the type is determined by Scheme value. GValue structure is initialized by this. */ GValue *Scm_ObjToGValue(ScmObj obj, GValue *gv) { gv->g_type = 0; if (SCM_INTP(obj)) { g_value_init(gv, G_TYPE_INT); g_value_set_int(gv, Scm_GetInteger(obj)); return gv; } if (SCM_BIGNUMP(obj)) { /*NB: check the value range */ g_value_init(gv, G_TYPE_INT); g_value_set_int(gv, Scm_GetInteger(obj)); return gv; } if (SCM_STRINGP(obj)) { g_value_init(gv, G_TYPE_STRING); g_value_set_string(gv, Scm_GetStringConst(SCM_STRING(obj))); return gv; } if (SCM_SYMBOLP(obj)) { g_value_init(gv, G_TYPE_STRING); g_value_set_string(gv, Scm_GetStringConst(SCM_SYMBOL_NAME(obj))); return gv; } if (SCM_BOOLP(obj)) { g_value_init(gv, G_TYPE_BOOLEAN); g_value_set_boolean(gv, SCM_BOOL_VALUE(obj)); return gv; } if (SCM_FLONUMP(obj)) { g_value_init(gv, G_TYPE_DOUBLE); g_value_set_double(gv, Scm_GetDouble(obj)); return gv; } if (SCM_GOBJECT_P(obj)) { GType gt = Scm_ClassToGtkType(SCM_CLASS_OF(obj)); if (gt != G_TYPE_INVALID) { g_value_init(gv, gt); g_value_set_object(gv, SCM_GOBJECT_OBJECT(obj)); return gv; } } Scm_Error("can't convert Scheme value %S to GValue", obj); return NULL; } /* mmc: i need a function, not side-effecting procedure. that's for define-ctype (genstub's instruction)*/ /* inline ? */ GValue *Scm_obj_to_gvalue (ScmObj obj) { GValue* g = malloc (sizeof(GValue)); return Scm_ObjToGValue (obj, g); } /* * GClosure interface */ typedef struct { GClosure closure; ScmProcedure *proc; int gpointers; /* number of gpointer GValues hinted */ char* gpointer_mapping; /* the hints: every char encodes a type. */ } SClosure; void Scm_mmc_GClosureMarshal(GClosure *closure, GValue *retval, guint nparams, const GValue *params, gpointer ihint, gpointer data) { ScmObj argh = SCM_NIL, argt = SCM_NIL, ret; ScmProcedure *proc = ((SClosure*)closure)->proc; int i; Scm_Warn("%s:", __FUNCTION__); /* max given by gauche VM ! */ /* Maximum # of values allowed for multiple value return */ int indexes[SCM_VM_MAX_VALUES]= {0}; /* bzero ?*/ int index = 0; int n = ((SClosure*)closure)->gpointers; char* types = ((SClosure*)closure)->gpointer_mapping; SCM_ASSERT(proc && SCM_PROCEDUREP(proc)); /* Scm_Warn("%s: looking for GPOINTERS %s", __FUNCTION__, types); */ for (i=0; i 0) { indexes[index++] = i; switch (*types){ case 'i': SCM_APPEND1(argh, argt, Scm_MakeInteger(* ((gint*)g_value_get_pointer(params+i)))); break; default: Scm_Warn("unknown type %c", *types); }; types++; } else { Scm_Warn("dunno about any more gpointers!!"); }; } else { /* params */ Scm_Warn("%s:\n", __FUNCTION__); SCM_APPEND1(argh, argt, Scm_UnboxGValue(params+i)); } } ret = call_callback(SCM_OBJ(proc), argh); #if 1 ScmVM* vm = Scm_VM(); ScmObj values = Scm_VMGetResult(vm); /* list of values. now we have to walk the argument list once again (we could have a list of indexes), and push the values to the Gpointers... */ #undef debug #define debug 1 #if debug Scm_Warn("result has %d values. and we have %d", Scm_Length(values), index); #endif if (Scm_Length(values) > 1) { /* we have to fill-in back the arguments.... the values pointed to by the arguments/ gpointers */ char* types = ((SClosure*)closure)->gpointer_mapping; ScmObj p; for (i = 0, p = SCM_CDR(values); (i < index) && SCM_PAIRP(p); i++, (p) = SCM_CDR(p)){ GType gt = G_VALUE_TYPE(params + indexes[i]); if (G_TYPE_FUNDAMENTAL(gt) == G_TYPE_POINTER) { switch (types[i]){ case 'i': { #if debug /* SCM_INT_VALUE(SCM_CAR(p)) */ int value = Scm_GetInteger(SCM_CAR(p)); /* value = 0; */ Scm_Warn("exporting integer value %d to: %d",value, indexes[i]); #endif (* ((gint*)g_value_get_pointer(params+indexes[i]))) = value; break; } default: Scm_Warn("unknown type %c skipping", types[i]); }; } else Scm_Warn("%s: index %d %d is no more a gtype, bug!", __FUNCTION__, i, indexes[i]); }; } #if debug Scm_Warn("returning"); #endif #else gint* pointer = (g_value_get_pointer(params+3)); Scm_Warn("not changing %d", *pointer); if (*pointer > 0) *pointer -= 1; Scm_Warn("not changing %d", *pointer); #endif if (retval) Scm_BoxGValue(retval, ret); Scm_Warn("%s: Ending", __FUNCTION__); } void Scm_GClosureMarshal(GClosure *closure, GValue *retval, guint nparams, const GValue *params, gpointer ihint, gpointer data) { ScmObj argh = SCM_NIL, argt = SCM_NIL, ret; ScmProcedure *proc = ((SClosure*)closure)->proc; int i; SCM_ASSERT(proc && SCM_PROCEDUREP(proc)); for (i=0; i unprotect it(remove from the hash) */ GClosure *Scm_MakeGClosure(ScmProcedure *procedure) { GClosure *c = g_closure_new_simple(sizeof(SClosure), NULL); ((SClosure*)c)->proc = procedure; Scm_GtkProtect(SCM_OBJ(procedure)); /* hash -> */ g_closure_add_finalize_notifier(c, (gpointer)procedure, Scm_GClosureDestroy); g_closure_set_marshal(c, Scm_GClosureMarshal); /* this, overrides the ?? */ return c; } void universal_cell_function (GtkTreeViewColumn *col, GtkCellRenderer *renderer, GtkTreeModel *model, GtkTreeIter *iter, gpointer user_data) { #if 0 /* type check! */ assert(); #endif /* i could keep a signature (C pointers to the column &...), and don't bother the scheme part w/ these args! */ #if 0 Scm_Warn("%s:", __FUNCTION__); #endif SClosure *closure = (SClosure*) user_data; ScmObj scm_col = Scm_MakeGObject(col); /* fixme: i could create it in the closure! */ ScmObj scm_renderer = Scm_MakeGObject(renderer); ScmObj scm_model = Scm_MakeGObject(model); ScmObj scm_iter = Scm_MakeGtkTreeIter(iter); /*Scm_MakeGObject(iter); */ GValue gval = {0}; gtk_tree_model_get_value(model, iter, 0, &gval); int number = 0; GType gt = G_VALUE_TYPE(&gval); if (G_TYPE_FUNDAMENTAL(gt) == G_TYPE_INT) number = g_value_get_int(&gval); g_value_unset(&gval); /* Scm_Warn ("%s: %d\n", __FUNCTION__, number); */ /* ScmProcedure *proc = */ /* (run_closure (); */ ScmProcedure *proc = ((SClosure*)closure)->proc; Scm_ApplyRec4(SCM_OBJ(proc), scm_col, scm_renderer, scm_iter, scm_model); #if 0 age_cell_data_function { gfloat age; gchar buf[20]; gtk_tree_model_get(model, iter, COLUMN_AGE_FLOAT, &age, -1); g_snprintf(buf, sizeof(buf), "%.1f", age); g_object_set(renderer, "text", buf, NULL); } #endif #if 0 Scm_Warn("%s: END", __FUNCTION__); #endif } #define mmc_debug 0 GClosure *Scm_MakeGClosure_mmc(ScmProcedure *procedure,ScmObj name) /* ScmString* ScmString*/ { GClosure *c = g_closure_new_simple(sizeof(SClosure), NULL); ((SClosure*)c)->proc = procedure; Scm_GtkProtect(SCM_OBJ(procedure)); /* hash -> */ g_closure_add_finalize_notifier(c, (gpointer)procedure, Scm_GClosureDestroy); ScmModule *module = SCM_MODULE(SCM_FIND_MODULE("gtk", TRUE)); /* SCM_OBJ(SCM_CURRENT_MODULE()) */ ScmSymbol *symbol = SCM_SYMBOL(SCM_INTERN("gpointer-mapping")); /* Scm_Intern((ScmString*) SCM_MAKE_STR("pg-handle-hook")) */ #if mmc_debug if (symbol) Scm_Warn("%s: found the symbol", __FUNCTION__); #endif ScmObj mapping = Scm_SymbolValue(module, symbol); #if mmc_debug if (mapping && (SCM_HASHTABLEP(mapping))) Scm_Warn("%s: found the value, too, Now searching for %s", __FUNCTION__, Scm_GetStringConst(SCM_STRING(name))); #endif ScmHashEntry* e = Scm_HashTableGet(SCM_HASHTABLE(mapping), name); if (mapping && (SCM_HASHTABLEP(mapping)) && /* find in the hash: */ (e)) { /* Scm_Warn("%s: found a hashtable", __FUNCTION__); */ if (SCM_PAIRP(e->value) && SCM_INTEGERP(SCM_CAR(e->value)) && SCM_STRINGP(SCM_CDR(e->value))) { /* Scm_Warn("%s: found an entry in the hashtable", __FUNCTION__); */ /* must be a cons/pair name -> (number . vector-or-string) */ ((SClosure*)c)->gpointers = Scm_GetInteger(SCM_CAR(e->value)); /* fixme: check the string lenght !!! */ ((SClosure*)c)->gpointer_mapping = Scm_GetString(SCM_STRING(SCM_CDR(e->value))); g_closure_set_marshal(c, Scm_mmc_GClosureMarshal); /* this, overrides the ?? */ goto end; } }; /* old: */ ((SClosure*)c)->gpointers = 0; g_closure_set_marshal(c, Scm_GClosureMarshal); /* this, overrides the ?? */ end: return c; } /* This can be passed to gtk_idle_add etc. */ gboolean Scm_GtkCallThunk(gpointer closure) { SCM_ASSERT(closure != NULL && SCM_PROCEDUREP(closure)); ScmObj ret = call_callback(SCM_OBJ(closure), SCM_NIL); return SCM_BOOL_VALUE(ret); } /* More general version. Returns a list of values. */ ScmObj Scm_GtkApply(ScmObj proc, ScmObj args) { call_callback(proc, args); return Scm_VMGetResult(Scm_VM()); } /*=============================================================== * Unix signal handling */ /* After gtk-main-loop, Gtk takes over the control of the * application. When an unix signal arrives, it is queued * in the Gauche VM signal queue and also it terminates the * poll() function inside Gtk main loop. However, Gtk knows * nothing about Gauche VM, so it re-invokes poll() if no other * event occurs---thus Gauche's signal handler will never be * called. * * Gtk doesn't provide a direct way to address this (idle * handler can't be used, for it would be a busy wait for the * unix signals). However, the underlying g_main_loop mechanism * that Gtk main loop uses has very flexible way to hook our * function inside the main loop. */ static gboolean scm_signal_prepare(GSource *source, gint *timeout) { *timeout = -1; return FALSE; } static gboolean scm_signal_check(GSource *source) { ScmVM *vm = Scm_VM(); return vm->signalPending; } static gboolean scm_signal_dispatch(GSource *source, GSourceFunc callback, gpointer user_data) { Scm_SigCheck(Scm_VM()); return TRUE; } GSourceFuncs scm_signal_watch_funcs = { scm_signal_prepare, scm_signal_check, scm_signal_dispatch, NULL }; static gboolean scm_signal_watcher_add(gpointer data) { GSource *source = g_source_new(&scm_signal_watch_funcs, sizeof(GSource)); /* attach to the default context, which Gtk seems to use. */ g_source_attach(source, NULL); return TRUE; } void Scm_GtkInitUnixSignalHook(void) { gtk_init_add(scm_signal_watcher_add, NULL); } /*=============================================================== * GTimer */ static void g_timer_finalize(ScmObj obj, void *data) { ScmGTimer *g = (ScmGTimer*)obj; g_timer_destroy(g->data); g->data = NULL; } ScmObj Scm_MakeGTimer(GTimer *r) { ScmGTimer *g = SCM_NEW(ScmGTimer); SCM_SET_CLASS(g, SCM_CLASS_GTIMER); g->data = r; Scm_RegisterFinalizer(SCM_OBJ(g), g_timer_finalize, NULL); return SCM_OBJ(g); } /*=============================================================== * Pango auxiliary structures */ SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_PangoLayoutIterClass, NULL); static void pango_layout_iter_finalize(ScmObj obj, void *data) { ScmPangoLayoutIter *g = (ScmPangoLayoutIter*)obj; pango_layout_iter_free(g->iter); g->iter = NULL; } ScmObj Scm_MakePangoLayoutIter(PangoLayoutIter *r) { ScmPangoLayoutIter *g = SCM_NEW(ScmPangoLayoutIter); SCM_SET_CLASS(g, SCM_CLASS_PANGO_LAYOUT_ITER); g->iter = r; Scm_RegisterFinalizer(SCM_OBJ(g), pango_layout_iter_finalize, NULL); return SCM_OBJ(g); } /*=============================================================== * GdkAtom <-> ScmObj mapping */ SCM_DEFINE_BUILTIN_CLASS(Scm_GdkAtomClass, NULL, NULL, NULL, NULL, Scm_GObjectCPL+1); ScmObj Scm_MakeGdkAtom(GdkAtom atom) { ScmGdkAtom *z = SCM_NEW(ScmGdkAtom); SCM_SET_CLASS(z, SCM_CLASS_GDK_ATOM); z->atom = atom; /* no refcounting needed */ return SCM_OBJ(z); } /*=============================================================== * gchar** <-> string list mapping */ gint Scm_GtkStringsToGcharArrays(ScmObj list, gchar ***chars) { int len = Scm_Length(list), i = 0; ScmObj cp; gchar **s = SCM_NEW2(gchar**, sizeof(gchar*)*len); SCM_FOR_EACH(cp, list) { if (!SCM_STRINGP(SCM_CAR(cp))) { Scm_Error("string requried, but got %S", SCM_CAR(cp)); } s[i++] = (gchar*)Scm_GetString(SCM_STRING(SCM_CAR(cp))); } *chars = s; return len; } ScmObj Scm_GtkGcharArraysToStrings(gint count, gchar **chars) { ScmObj h = SCM_NIL, t = SCM_NIL; int i; for (i=0; i property data (used by gtk-property stuff) */ /* gtk-property-change accepts u8, u16, and u32vector as the property data. u8 and u16 vectors are directly mapped to guchar* and gushort*. We need a special care to map u32vector to gulong*. */ guchar* Scm_GdkPropertyDataFromUVector(ScmObj uvec, int *format, /* out */ int *nelements) /* out */ { if (SCM_U8VECTORP(uvec)) { *nelements = SCM_U8VECTOR_SIZE(uvec); *format = 8; return (guchar*)SCM_U8VECTOR_ELEMENTS(uvec); } else if (SCM_U16VECTORP(uvec)) { *nelements = SCM_U16VECTOR_SIZE(uvec); *format = 16; return (guchar*)SCM_U16VECTOR_ELEMENTS(uvec); } else if (SCM_U32VECTORP(uvec)) { *nelements = SCM_U32VECTOR_SIZE(uvec); *format = 32; #if SIZEOF_LONG == 4 return (guchar*)SCM_U32VECTOR_ELEMENTS(uvec); #else { gulong *buf = SCM_NEW_ATOMIC2(gulong*, (*nelements)*sizeof(gulong)); int i; for (i=0; i<*nelements; i++) { buf[i] = (gulong)(SCM_U32VECTOR_ELEMENTS(uvec)[i]); } return (guchar*)buf; } #endif } else { Scm_Error("property data must be either u8, u16, or u32vector, but got %S", uvec); return NULL; /* dummy */ } } /*=============================================================== * GdkEvent */ extern ScmClass Scm_GdkEventAnyClass; extern ScmClass Scm_GdkEventExposeClass; extern ScmClass Scm_GdkEventMotionClass; extern ScmClass Scm_GdkEventButtonClass; extern ScmClass Scm_GdkEventKeyClass; extern ScmClass Scm_GdkEventCrossingClass; extern ScmClass Scm_GdkEventFocusClass; extern ScmClass Scm_GdkEventConfigureClass; extern ScmClass Scm_GdkEventPropertyClass; extern ScmClass Scm_GdkEventSelectionClass; extern ScmClass Scm_GdkEventProximityClass; extern ScmClass Scm_GdkEventDNDClass; extern ScmClass Scm_GdkEventClientClass; extern ScmClass Scm_GdkEventVisibilityClass; extern ScmClass Scm_GdkEventNoExposeClass; extern ScmClass Scm_GdkEventScrollClass; extern ScmClass Scm_GdkEventWindowStateClass; extern ScmClass Scm_GdkEventSettingClass; /* maps event->type to the class of the event */ static struct EvClassTableRec { GdkEventType type; ScmClass *klass; } evClassTable[] = { { GDK_DELETE, &Scm_GdkEventAnyClass }, { GDK_DESTROY, &Scm_GdkEventAnyClass }, { GDK_EXPOSE, &Scm_GdkEventExposeClass }, { GDK_MOTION_NOTIFY, &Scm_GdkEventMotionClass }, { GDK_BUTTON_PRESS, &Scm_GdkEventButtonClass }, { GDK_2BUTTON_PRESS, &Scm_GdkEventButtonClass }, { GDK_3BUTTON_PRESS, &Scm_GdkEventButtonClass }, { GDK_BUTTON_RELEASE, &Scm_GdkEventButtonClass }, { GDK_KEY_PRESS, &Scm_GdkEventKeyClass }, { GDK_KEY_RELEASE, &Scm_GdkEventKeyClass }, { GDK_ENTER_NOTIFY, &Scm_GdkEventCrossingClass }, { GDK_LEAVE_NOTIFY, &Scm_GdkEventCrossingClass }, { GDK_FOCUS_CHANGE, &Scm_GdkEventFocusClass }, { GDK_CONFIGURE, &Scm_GdkEventConfigureClass }, { GDK_MAP, &Scm_GdkEventAnyClass }, { GDK_UNMAP, &Scm_GdkEventAnyClass }, { GDK_PROPERTY_NOTIFY, &Scm_GdkEventPropertyClass }, { GDK_SELECTION_CLEAR, &Scm_GdkEventSelectionClass }, { GDK_SELECTION_REQUEST,&Scm_GdkEventSelectionClass }, { GDK_SELECTION_NOTIFY, &Scm_GdkEventSelectionClass }, { GDK_PROXIMITY_IN, &Scm_GdkEventProximityClass }, { GDK_PROXIMITY_OUT, &Scm_GdkEventProximityClass }, { GDK_DRAG_ENTER, &Scm_GdkEventDNDClass }, { GDK_DRAG_LEAVE, &Scm_GdkEventDNDClass }, { GDK_DRAG_MOTION, &Scm_GdkEventDNDClass }, { GDK_DRAG_STATUS, &Scm_GdkEventDNDClass }, { GDK_DROP_START, &Scm_GdkEventDNDClass }, { GDK_DROP_FINISHED, &Scm_GdkEventDNDClass }, { GDK_CLIENT_EVENT, &Scm_GdkEventClientClass }, { GDK_VISIBILITY_NOTIFY,&Scm_GdkEventVisibilityClass }, { GDK_NO_EXPOSE, &Scm_GdkEventNoExposeClass }, { GDK_SCROLL, &Scm_GdkEventScrollClass }, { GDK_WINDOW_STATE, &Scm_GdkEventWindowStateClass }, { GDK_SETTING, &Scm_GdkEventSettingClass }, { -1, &Scm_GdkEventAnyClass } }; /* fixme: These are valid GTypes, aren't they? So I should put them into the hash! */ SCM_DEFINE_BUILTIN_CLASS(Scm_GdkEventClass, NULL, NULL, NULL, NULL, Scm_GObjectCPL+1); static void gdk_event_finalize(ScmObj obj, void *data) { ScmGdkEvent *e = (ScmGdkEvent*)obj; gdk_event_free(e->data); e->data = NULL; } ScmObj Scm_MakeGdkEvent(GdkEvent *r) { ScmClass *klass = &Scm_GdkEventAnyClass; ScmGdkEvent *g; struct EvClassTableRec *ctab; for (ctab = evClassTable; ctab->type >= 0; ctab++) { if (((GdkEventAny*)r)->type == ctab->type) { klass = ctab->klass; break; } } g = SCM_NEW(ScmGdkEvent); SCM_SET_CLASS(g, klass); g->data = gdk_event_copy(r); Scm_RegisterFinalizer(SCM_OBJ(g), gdk_event_finalize, NULL); return SCM_OBJ(g); } /*=============================================================== * GList & GSList */ /* these 2 would be templates, in C++, imho. -- mmc! */ ScmObj Scm_GoListToList(GList *list) { ScmObj h = SCM_NIL, t = SCM_NIL; while (list) { if (!list->data) Scm_Error("GList->List: list contains NULL"); if (!G_IS_OBJECT(list->data)) { Scm_Error("GList->List: list contains non-GObject"); } SCM_APPEND1(h, t, SCM_GOBJECT_BOX(list->data)); list = g_list_next(list); } return h; } /* this is for `Single'-link'ed lists. */ ScmObj Scm_GoSListToList(GSList *list) { ScmObj h = SCM_NIL, t = SCM_NIL; while (list) { if (!list->data) Scm_Error("GSList->List: list contains NULL"); if (!G_IS_OBJECT(list->data)) { Scm_Error("GSList->List: list contains non-GObject"); } SCM_APPEND1(h, t, SCM_GOBJECT_BOX(list->data)); list = g_slist_next(list); } return h; } GList *Scm_ListToGList(ScmObj list) { GList *glist = NULL; ScmObj lp; SCM_FOR_EACH(lp, list) { ScmObj elt = SCM_CAR(lp); if (!SCM_GOBJECT_P(elt)) { if (glist) g_list_free(glist); Scm_Error("List of required, but the list contains %S", elt); } glist = g_list_append(glist, SCM_GOBJECT_OBJECT(elt)); } return glist; } GSList *Scm_ListToGSList(ScmObj list) { GSList *glist = NULL; ScmObj lp; SCM_FOR_EACH(lp, list) { ScmObj elt = SCM_CAR(lp); if (!SCM_GOBJECT_P(elt)) { if (glist) g_slist_free(glist); Scm_Error("List of required, but the list contains %S", elt); } glist = g_slist_append(glist, SCM_GOBJECT_OBJECT(elt)); } return glist; } /* mmc: unboxing as a function .... Frees the argument*/ ScmObj Scm_GList_to_list(GList *list) { ScmObj r = Scm_GoListToList(list); g_list_free(list); SCM_RETURN(r); }; ScmObj Scm_const_GList_to_list(GList *list) { ScmObj r = Scm_GoListToList(list); /* g_list_free(list); */ SCM_RETURN(r); }; /*=============================================================== * String list and array */ const char **Scm_StringListToStringArray(ScmObj list) { int len = Scm_Length(list), i = 0; ScmObj lp; const char **a; if (len < 0) Scm_Error("proper list required, but got %S", list); a = SCM_NEW2(const char **, (len+1)*sizeof(char *)); SCM_FOR_EACH(lp, list) { if (!SCM_STRINGP(SCM_CAR(lp))) Scm_Error("string required, but got %S", SCM_CAR(lp)); a[i] = Scm_GetStringConst(SCM_STRING(SCM_CAR(lp))); i++; } a[i] = NULL; return a; } /*=============================================================== * Arrays of primitive types */ SCM_DEFINE_BUILTIN_CLASS(Scm_GdkPointVectorClass, NULL, NULL, NULL, NULL, Scm_GObjectCPL+1); ScmObj Scm_MakeGdkPointVector(GdkPoint *pts, int npts) { ScmGdkPointVector *r = SCM_NEW(ScmGdkPointVector); /* see .h */ SCM_SET_CLASS(r, SCM_CLASS_GDK_POINT_VECTOR); r->size = npts; r->elements = SCM_NEW_ATOMIC2(GdkPoint*, sizeof(GdkPoint[1])*npts); if (pts) memcpy(r->elements, pts, sizeof(GdkPoint[1])*npts); return SCM_OBJ(r); } SCM_DEFINE_BUILTIN_CLASS(Scm_GdkSegmentVectorClass, NULL, NULL, NULL, NULL, Scm_GObjectCPL+1); ScmObj Scm_MakeGdkSegmentVector(GdkSegment *segs, int nsegs) { ScmGdkSegmentVector *r = SCM_NEW(ScmGdkSegmentVector); SCM_SET_CLASS(r, SCM_CLASS_GDK_SEGMENT_VECTOR); r->size = nsegs; r->elements = SCM_NEW_ATOMIC2(GdkSegment*, sizeof(GdkSegment[1])*nsegs); if (segs) memcpy(r->elements, segs, sizeof(GdkSegment[1])*nsegs); return SCM_OBJ(r); } SCM_DEFINE_BUILTIN_CLASS(Scm_GdkRectangleVectorClass, NULL, NULL, NULL, NULL, Scm_GObjectCPL+1); ScmObj Scm_MakeGdkRectangleVector(GdkRectangle *rects, int nrects) { ScmGdkRectangleVector *r = SCM_NEW(ScmGdkRectangleVector); SCM_SET_CLASS(r, SCM_CLASS_GDK_RECTANGLE_VECTOR); r->size = nrects; r->elements = SCM_NEW_ATOMIC2(GdkRectangle*, sizeof(GdkRectangle[1])*nrects); if (rects) memcpy(r->elements, rects, sizeof(GdkRectangle[1])*nrects); return SCM_OBJ(r); } SCM_DEFINE_BUILTIN_CLASS(Scm_GdkColorVectorClass, NULL, NULL, NULL, NULL, Scm_GObjectCPL+1); ScmObj Scm_MakeGdkColorVector(GdkColor *colors, int ncolors) { ScmGdkColorVector *r = SCM_NEW(ScmGdkColorVector); SCM_SET_CLASS(r, SCM_CLASS_GDK_COLOR_VECTOR); r->size = ncolors; r->elements = SCM_NEW_ATOMIC2(GdkColor*, sizeof(GdkColor[1])*ncolors); if (colors) memcpy(r->elements, colors, sizeof(GdkColor[1])*ncolors); return SCM_OBJ(r); } /*=============================================================== * RadioGroup */ /* See the comment of header file about ScmGtkRadioGroup */ static int radio_group_compare(ScmObj x, ScmObj y, int equalp) { ScmObj rx, ry; GObject *gx, *gy; if (!equalp) Scm_Error("can't order %S and %S", x, y); rx = SCM_GTK_RADIO_GROUP(x)->radio; ry = SCM_GTK_RADIO_GROUP(x)->radio; if (SCM_FALSEP(rx)) { return SCM_FALSEP(ry)? 0 : -1; } SCM_ASSERT(SCM_GOBJECT_P(rx) && SCM_GOBJECT_P(ry)); gx = SCM_GOBJECT_OBJECT(rx); gy = SCM_GOBJECT_OBJECT(ry); if (GTK_IS_RADIO_BUTTON(gx)) { if (GTK_IS_RADIO_BUTTON(gy)) { GtkRadioButton *bx = GTK_RADIO_BUTTON(gx); GtkRadioButton *by = GTK_RADIO_BUTTON(gy); return (gtk_radio_button_get_group(bx) == gtk_radio_button_get_group(by))? 0 : -1; } return -1; } if (GTK_IS_RADIO_MENU_ITEM(gx)) { if (GTK_IS_RADIO_MENU_ITEM(gy)) { GtkRadioMenuItem *bx = GTK_RADIO_MENU_ITEM(gx); GtkRadioMenuItem *by = GTK_RADIO_MENU_ITEM(gy); return (gtk_radio_menu_item_get_group(bx) == gtk_radio_menu_item_get_group(by))? 0 : -1; } return -1; } return -1; } SCM_DEFINE_BUILTIN_CLASS(Scm_GtkRadioGroupClass, NULL, radio_group_compare, NULL, NULL, NULL); /* 'radio' must be either a GtkRadioButton or a GtkRadioMenuItem */ ScmObj Scm_MakeGtkRadioGroup(GObject *radio) { GSList *glist = NULL; ScmGtkRadioGroup *group; if (GTK_IS_RADIO_BUTTON(radio)) { glist = gtk_radio_button_get_group(GTK_RADIO_BUTTON(radio)); } else if (GTK_IS_RADIO_MENU_ITEM(radio)) { glist = gtk_radio_menu_item_get_group(GTK_RADIO_MENU_ITEM(radio)); } else { Scm_Error(" can be created only for or object, but got an instance of %s", g_type_name(G_OBJECT_TYPE(radio))); } group = SCM_NEW(ScmGtkRadioGroup); SCM_SET_CLASS(group, SCM_CLASS_GTK_RADIO_GROUP); if (glist != NULL) { group->radio = Scm_MakeGObject(radio); } else { group->radio = SCM_FALSE; } return SCM_OBJ(group); } GSList *Scm_GtkRadioGroupGetGroup(ScmObj g) { GObject *gradio; ScmGtkRadioGroup *group; if (SCM_FALSEP(g)) return NULL; if (!SCM_GTK_RADIO_GROUP_P(g)) { Scm_Error(" or #f required, but got %S", g); } group = SCM_GTK_RADIO_GROUP(g); if (SCM_FALSEP(group->radio)) return NULL; SCM_ASSERT(SCM_GOBJECT_P(group->radio)); gradio = SCM_GOBJECT_OBJECT(group->radio); if (GTK_IS_RADIO_BUTTON(gradio)) { return gtk_radio_button_get_group(GTK_RADIO_BUTTON(gradio)); } if (GTK_IS_RADIO_MENU_ITEM(gradio)) { return gtk_radio_menu_item_get_group(GTK_RADIO_MENU_ITEM(gradio)); } Scm_Error("internal inconsistency in %S", group); return NULL; /* dummy */ } ScmObj Scm_GtkRadioGroupToList(ScmGtkRadioGroup *group) { GSList *glist = Scm_GtkRadioGroupGetGroup(SCM_OBJ(group)); if (glist == NULL) return SCM_NIL; else return Scm_GoSListToList(glist); } /*=============================================================== * Initialization */ #include "gtk-lib.inits" extern void Scm_Init_gauche_glib(ScmModule*); extern void Scm_Init_gauche_gdklib(ScmModule*); /* mmc! */ void Scm_Init_gauche_gtk(void) { ScmModule *mod; SCM_INIT_EXTENSION(gauche_gtk); mod = SCM_MODULE(SCM_FIND_MODULE("gtk", TRUE)); g_type_init(); gtkdata.scmclass_key = g_quark_from_static_string("ScmClass"); gtkdata.scmobj_key = g_quark_from_static_string("ScmObj"); referenced_gobjects = SCM_HASHTABLE(Scm_MakeHashTable(SCM_HASH_ADDRESS, NULL, 0)); (void)SCM_INTERNAL_MUTEX_INIT(gtkdata.protected_mutex); gtkdata.protected = SCM_HASHTABLE(Scm_MakeHashTable(SCM_HASH_ADDRESS, NULL, 0)); (void)SCM_INTERNAL_MUTEX_INIT(gtkdata.typemap_mutex); gtkdata.typemap = SCM_HASHTABLE(Scm_MakeHashTable(SCM_HASH_ADDRESS, NULL, 0)); /* mmc: This is the first part. good! */ typemap_initialize(gtkdata.typemap); Scm_InitBuiltinClass(&Scm_GObjectClass, "", NULL, sizeof(ScmGObject), mod); Scm_InitBuiltinClass(&Scm_GTypeClass, "", NULL, sizeof(ScmGType), mod); Scm_InitBuiltinClass(&Scm_PangoLayoutIterClass, "", NULL, sizeof(ScmPangoLayoutIter), mod); Scm_InitBuiltinClass(&Scm_GdkAtomClass, "", NULL, sizeof(ScmGdkAtom), mod); Scm_InitBuiltinClass(&Scm_GdkEventClass, "", NULL, sizeof(ScmGdkEvent), mod); Scm_InitBuiltinClass(&Scm_GdkRegionClass, "", NULL, sizeof(ScmGdkRegion), mod); Scm_InitBuiltinClass(&Scm_GdkPointVectorClass, "", NULL, sizeof(ScmGdkPointVector), mod); Scm_InitBuiltinClass(&Scm_GdkSegmentVectorClass, "", NULL, sizeof(ScmGdkSegmentVector), mod); Scm_InitBuiltinClass(&Scm_GdkRectangleVectorClass, "", NULL, sizeof(ScmGdkRectangleVector), mod); Scm_InitBuiltinClass(&Scm_GdkColorVectorClass, "", NULL, sizeof(ScmGdkColorVector), mod); Scm_InitBuiltinClass(&Scm_GtkRadioGroupClass, "", NULL, sizeof(ScmGtkRadioGroup), mod); Scm_Init_gauche_glib(mod); Scm_Init_gauche_gdklib(mod); Scm_Init_gtk_lib(mod); /* this is in gtk-lib.inits ! */ #if 1 /* Now I should register the Event GTypes! */ Scm_GtkRegisterClass(GDK_TYPE_EVENT, &Scm_GdkEventAnyClass); #else { ScmClass *klass = &Scm_GdkEventAnyClass; ScmGdkEvent *g; struct EvClassTableRec *ctab; { int count = 0; for (ctab = evClassTable; ctab->type >= 0; ctab++) count++; Scm_Warn("registering GDK %d events\n", __FUNCTION__, count); /* sizeof(evClassTable)/sizeof(evClassTable[0]), array_size */ } for (ctab = evClassTable; ctab->type >= 0; ctab++) { Scm_GtkRegisterClass(ctab->type, ctab->klass); } } #endif Scm_GtkInitUnixSignalHook(); /* mmc: */ #if 0 hint_table = (ScmHashTable*) Scm_MakeHashTable((ScmHashProc) SCM_HASH_STRING, /* (ScmHashProc) Scm_HashString_mmc, */ (ScmHashCmpProc) NULL, /* Scm_EqvHash_mmc, /* typedef int (*ScmHashCmpProc)(ScmObj, ScmHashEntry *); * * string = ?? */ 1000); #endif } /* mmc:*/ /* implementing */ int SCM_STRING_LIST_P(ScmObj x) { ScmObj p; if (SCM_LISTP(x)){ SCM_FOR_EACH(p, x){ if (! SCM_STRINGP(SCM_CAR(p))) return 0; } return 1; } else return 0; } /* unboxer: */ gchar** SCM_STRING_LIST(ScmObj x) { int len = Scm_Length(x); /* allocate the array of pointers */ gchar** cstrings = (malloc (1 + len)); /* should i malloc all the space at once? */ ScmObj p; int index = 0; /* allocate the single strings */ for((p) = (x); SCM_PAIRP(p); (p) = SCM_CDR(p)){ cstrings[index++] = (gchar*) Scm_GetStringConst((ScmString *) SCM_CAR(p)); } cstrings[len] = 0; return cstrings; } ScmObj SCM_MAKE_STRING_LIST(gchar** cstring) { int len = 0; gchar** head = cstring; while (*cstring++) len++; #if GAUCHE_MAJOR_VERSION == 0 && GAUCHE_MINOR_VERSION == 8 && GAUCHE_MICRO_VERSION <= 6 return Scm_CStringArrayToList(head, len); #else /* fixme: gchar vs char ? */ return Scm_CStringArrayToList((const char**) head, len, SCM_MAKSTR_COPYING); #endif } /* Get the list of Signals: */ /* implementing GSignalQuery type:*/ static void ScmGSignalQuery_finalize(ScmObj obj, void* data) { /* no need to test. the finalizer has just been deduced from the structure itself ? */ GSignalQuery *g = SCM_G_SIGNAL_QUERY(obj); #if 0 printf("pg_finalize\\n"); #endif if (g) { g_free(g); g = NULL; } /* fixme: bug! Should be compatible with g-signal-query in gauche-glib.stub */ } ScmObj Scm_Make_GSignalQuery (GSignalQuery *data) { ScmGSignalQuery* g = SCM_NEW(ScmGSignalQuery); SCM_SET_CLASS(g, SCM_CLASS_G_SIGNAL_QUERY); g->data = data; g->name = (ScmString*) SCM_MAKE_STR_COPYING(data->signal_name); /* fixme: constant! */ Scm_RegisterFinalizer(SCM_OBJ(g), ScmGSignalQuery_finalize, NULL); return SCM_OBJ(g); }; #define DEBUG_EMIT 0 ScmObj Scm_g_signal_emit(ScmObj destination, int signal_id, int detail, ScmObj params) { /* Can signals be emitted on gobjects only? Here we assume so!*/ if (!SCM_GOBJECT_P(destination)) Scm_Error(" required, but got %S", destination); /* GObject *gobject = Scm_GObjectCheck (SCM_GOBJECT(destination)); */ /* Get the info */ GSignalQuery g = {0}; g_signal_query(signal_id,&g); if (g.signal_id == 0) { Scm_Error("gobject says: This signal %d is unknown!", signal_id); } /* Check if signal can be applied to gobject */ #if 1 GType desc_gtype = Scm_ClassToGtkType(SCM_CLASS_OF(destination)); if (!g_type_is_a(desc_gtype, g.itype)) { Scm_Error("gobject says: This signal %s cannot be emited on %S. Needs %s", g.signal_name, destination, g_type_name(g.itype)) ; /* cname */ } #else ScmClass* klass = Scm_GtkTypeToScmClass(g.itype); /* this might be tested in g- tools ? */ if (! SCM_XTYPEP(destination, klass)) { Scm_Warn("The signal cannot be applied!"); #if 0 /* type_name */ const char* cname; if (! klass->name) /* SCM_UNDEFINED?*/ cname = "???"; else { Scm_Warn("\tGetting the name!"); cname = Scm_GetString(SCM_STRING(klass->name)); } Scm_Warn("\tGot the name!"); #endif Scm_Error("This signal %s cannot be emited on %S", g.signal_name, klass) ; /* cname */ } #endif #if DEBUG_EMIT Scm_Warn("The signal can be applied to this gobject!"); #endif /* Check the number & types of args */ if (Scm_Length(params) != g.n_params) Scm_Error("wrong number of signal parameters: %d should be %d", Scm_Length(params), g.n_params); { int i = 0; ScmObj p; SCM_FOR_EACH(p, params) { #if 0 ScmClass* klass = Scm_GtkTypeToScmClass(g.param_types[i]); if (! SCM_XTYPEP(SCM_CAR(p), klass)) { Scm_Error("wrong argument %d: for signal %s, wants %s you provided %S", i, g.signal_name, g_type_name(g.param_types[i]), SCM_CAR(p)); } /* GtkMovementStep -> int */ #else #if DEBUG_EMIT Scm_Warn("testing type of param %d", i); #endif /* Get the SCM klass -> GType and ask if the value GType is ok ...*/ ScmObj o = SCM_CAR(p); ScmClass *klass; if (SCM_INTEGERP(o)) klass = SCM_CLASS_INTEGER; else klass = SCM_CLASS_OF(o); GType gtype = Scm_ClassToGtkType(klass); if (gtype == G_TYPE_INVALID) Scm_Error("wrong argument %d: %S", i, SCM_CAR(p)); #if DEBUG_EMIT Scm_Warn("comparing 2 gtypes: %s %s", g_type_name(gtype), g_type_name(g.param_types[i])); #endif if (! ( g_type_is_a(g.param_types[i], gtype) || (g_type_is_a(g.param_types[i], G_TYPE_ENUM)) && SCM_INTEGERP(o))) { Scm_Error("wrong argument %d: for signal %s, wants %s you provided %S", i, g.signal_name, g_type_name(g.param_types[i]), SCM_CAR(p)); } #endif i++; }; #if DEBUG_EMIT Scm_Warn("The signal parameters are of correct types!"); #endif } /* todo: How to test can we accept the return type? */ { GValue return_val = {0}; g_value_init(&return_val, g.return_type); GValue* instance_and_params = g_new0(GValue, g.n_params + 1); g_value_init(instance_and_params, g.itype); Scm_BoxGValue(instance_and_params, destination); /* Should I provide a fixed Gtype? */ int i = 1; ScmObj p; SCM_FOR_EACH(p, params) { #if DEBUG_EMIT Scm_Warn("converting %d %S", i-1, SCM_CAR(p)); #endif g_value_init(instance_and_params + i, g.param_types[i-1]); Scm_BoxGValue(instance_and_params +i, SCM_CAR(p)); i++; } g_signal_emitv(instance_and_params, signal_id, detail, &return_val); /* todo: return the returned Gvalue. */ SCM_RETURN(SCM_UNDEFINED); } } /* print method of * the class. Could be done in scheme (given gdk-pixbuf-format-get-name) ? * mmc: Maybe not. I want info on NULL connection too. But working w/ such complicates all? */ void gauche_gdk_pixbuf_format_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx) { GdkPixbufFormat* f=SCM_GDK_PIXBUF_FORMAT(obj); if (f) /* fixme! gobject_live ? */ { Scm_Printf(out, "#", gdk_pixbuf_format_get_name(f)); /* fixme: no name */ } else Scm_Printf(out, "#"); } gauche-gtk-0.6+git20160927/src/gauche-gtk.h000066400000000000000000000302121300401456300177610ustar00rootroot00000000000000/* * gauche-gtk.h - Gauche+Gtk extension * * Copyright(C) 2002-2004 by Shiro Kawai (shiro@acm.org) * * Permission to use, copy, modify, distribute this software and * accompanying documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in all * distributions. * This software is provided as is, without express or implied * warranty. In no circumstances the author(s) shall be liable * for any damages arising out of the use of this software. * * $Id: gauche-gtk.h,v 1.44 2007/01/13 01:36:31 maruska Exp $ */ #ifndef GAUCHE_GTK_H #define GAUCHE_GTK_H #include #include #include #include #include #include #include /* This should go to Gauche core, but for now ...*/ #ifndef SCM_RETURN2 #define SCM_RETURN2(a, b) SCM_RETURN(Scm_Values2(a, b)) #endif #ifndef SCM_RETURN3 #define SCM_RETURN3(a, b, c) SCM_RETURN(Scm_Values3(a, b, c)) #endif #ifndef SCM_RETURN4 #define SCM_RETURN4(a, b, c, d) SCM_RETURN(Scm_Values4(a, b, c, d)) #endif #ifndef SCM_RETURN5 #define SCM_RETURN5(a, b, c, d, e) SCM_RETURN(Scm_Values5(a, b, c, d, e)) #endif SCM_DECL_BEGIN /* * Generally useful macros */ #define CONST_GCHAR_PTR(string) \ ((const gchar*)Scm_GetStringConst(SCM_STRING(string))) #define CONST_CHAR_PTR(string) \ ((const char*)Scm_GetStringConst(SCM_STRING(string))) #define SCM_STRING_OR_NULL_P(obj) \ (SCM_FALSEP(obj)||SCM_STRINGP(obj)) #define CONST_GCHAR_PTR_NULLABLE(string) \ (SCM_FALSEP(string)?NULL:CONST_GCHAR_PTR(string)) #define SCM_MAKE_STR_COPYING_SAFELY(char_ptr) \ ((char_ptr)?SCM_MAKE_STR_COPYING(char_ptr):SCM_FALSE) /* box returned allocated gchar* string */ #define GCHAR_PTR_BOX(string) Scm_GtkGcharPtrBox(string) extern ScmObj Scm_GtkGcharPtrBox(gchar *s); /* This should go to Gauche core, but for now ...*/ #ifndef GAUCHE_MAJOR_VERSION typedef void (*ScmFinalizerProc)(ScmObj z, void *data); extern void Scm_RegisterFinalizer(ScmObj z, ScmFinalizerProc finalizer, void *data); #endif /* * GObject <-> ScmObj mapping */ /* Scheme view of GObject. See gauche-gtk.c for discussion on memory management. */ typedef struct ScmGObjectRec { SCM_INSTANCE_HEADER; GObject *gobject; /* can be NULL if explicitly unreferenced */ ScmObj data; /* emulate g_object_{get|set}_data */ /* mmc! */ int ref_count; gulong destroy_handler; /* see `make_gobject' */ } ScmGObject; SCM_CLASS_DECL(Scm_GObjectClass); #define SCM_CLASS_GOBJECT (&Scm_GObjectClass) #define SCM_GOBJECT(obj) ((ScmGObject*)(obj)) #define SCM_GOBJECT_P(obj) Scm_TypeP(obj, SCM_CLASS_GOBJECT) #define SCM_GOBJECT_OBJECT(obj) G_OBJECT(Scm_GObjectCheck(SCM_GOBJECT(obj))) #define SCM_GOBJECT_UNBOX(caster, obj) \ (SCM_FALSEP(obj)?NULL:caster(Scm_GObjectCheck(SCM_GOBJECT(obj)))) #define SCM_GOBJECT_BOX(obj) Scm_MakeGObject(obj) /* Register the association of GType and ScmClass; must be called in init */ extern void Scm_GtkRegisterClass(GType type, ScmClass *class); /* mmc: fixme: why do i export it? Isn't it solved by the _after patch?*/ /* extern*/ /* static int gobject_compare(ScmObj x, ScmObj y, int equalp); */ /* GType -> ScmClass; may return NULL */ extern ScmClass *Scm_GtkTypeToScmClass(GType type); /* ScmClass -> GType; may return G_TYPE_INVALID */ extern GType Scm_ClassToGtkType(ScmClass *k); extern int Scm_ClassListToGtkTypeList(ScmObj klasses, GType *g); /* mmc: */ ScmObj Scm_GList_to_list(GList *list); extern int SCM_STRING_LIST_P(ScmObj x); extern gchar** SCM_STRING_LIST(ScmObj x); extern ScmObj SCM_MAKE_STRING_LIST(gchar** cstring); /* GValue <-> ScmObj conversion */ extern ScmObj Scm_UnboxGValue(const GValue *gv); extern void Scm_BoxGValue(GValue *gv, ScmObj sv); extern GValue *Scm_ObjToGValue(ScmObj obj, GValue *gv); extern GObject *Scm_GObjectCheck(ScmGObject *obj); extern ScmClass *Scm_GObjectCPL[]; extern ScmObj Scm_MakeGObject(void *obj); extern void Scm_GtkProtect(ScmObj closure); extern void Scm_GtkUnprotect(gpointer data); extern void Scm_GObjectUnref(ScmGObject *gobj); extern ScmObj Scm_GObjectGetData(ScmGObject *gobj, ScmObj key, ScmObj fallback); extern ScmObj Scm_GObjectSetData(ScmGObject *gobj, ScmObj key, ScmObj data); extern ScmObj Scm_GtkObjectAllocate(ScmClass *klass, ScmObj initargs); GClosure *Scm_MakeGClosure(ScmProcedure *procedure); GClosure *Scm_MakeGClosure_mmc(ScmProcedure *procedure, ScmObj name); extern gboolean Scm_GtkCallThunk(gpointer data); extern ScmObj Scm_GtkApply(ScmObj proc, ScmObj args); extern void universal_cell_function(GtkTreeViewColumn *col, GtkCellRenderer *renderer, GtkTreeModel *model, GtkTreeIter *iter, gpointer user_data); /* * Unix signal handling hook (see the comments in gauche-gtk.c) */ extern void Scm_GtkInitUnixSignalHook(void); /* * GTimer */ typedef struct ScmGTimerRec { SCM_HEADER; GTimer *data; } ScmGTimer; SCM_CLASS_DECL(Scm_GTimerClass); #define SCM_CLASS_GTIMER (&Scm_GTimerClass) #define SCM_GTIMER_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GTIMER) #define SCM_GTIMER(obj) (((ScmGTimer*)(obj))->data) #define SCM_MAKE_GTIMER(obj) Scm_MakeGTimer(obj) extern ScmObj Scm_MakeGTimer(GTimer *data); /* * Pango auxiliary structures */ typedef struct ScmPangoLayoutIterRec { SCM_HEADER; PangoLayoutIter *iter; } ScmPangoLayoutIter; SCM_CLASS_DECL(Scm_PangoLayoutIterClass); #define SCM_CLASS_PANGO_LAYOUT_ITER (&Scm_PangoLayoutIterClass) #define SCM_PANGO_LAYOUT_ITER_P(obj) SCM_XTYPEP(obj, SCM_CLASS_PANGO_LAYOUT_ITER) #define SCM_PANGO_LAYOUT_ITER(obj) (((ScmPangoLayoutIter*)(obj))->iter) #define SCM_MAKE_PANGO_LAYOUT_ITER(obj) Scm_MakePangoLayoutIter(obj) extern ScmObj Scm_MakePangoLayoutIter(PangoLayoutIter *iter); /* * GdkAtom <-> ScmGdkAtom */ typedef struct ScmGdkAtomRec { SCM_HEADER; GdkAtom atom; } ScmGdkAtom; SCM_CLASS_DECL(Scm_GdkAtomClass); #define SCM_CLASS_GDK_ATOM (&Scm_GdkAtomClass) #define SCM_GDK_ATOM_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GDK_ATOM) #define SCM_GDK_ATOM(obj) (((ScmGdkAtom*)(obj))->atom) #define SCM_MAKE_GDK_ATOM(obj) Scm_MakeGdkAtom(obj) extern ScmObj Scm_MakeGdkAtom(GdkAtom atom); /* * GdkEvent is declared as union. */ typedef struct ScmGdkEventRec { SCM_HEADER; GdkEvent *data; /* memory belongs to Scheme */ } ScmGdkEvent; SCM_CLASS_DECL(Scm_GdkEventClass); #define SCM_CLASS_GDK_EVENT (&Scm_GdkEventClass) #define SCM_GDK_EVENT_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GDK_EVENT) #define SCM_GDK_EVENT(obj) (((ScmGdkEvent*)(obj))->data) #define SCM_MAKE_GDK_EVENT(obj) Scm_MakeGdkEvent(obj) extern ScmObj Scm_MakeGdkEvent(GdkEvent *r); /* * GList, GSList <-> Scheme list */ extern ScmObj Scm_GoListToList(GList *list); extern ScmObj Scm_GoSListToList(GSList *list); extern GList *Scm_ListToGList(ScmObj list); extern GSList *Scm_ListToGSList(ScmObj list); /* * String list -> C String array */ extern const char **Scm_StringListToStringArray(ScmObj list); /* * property utility */ guchar* Scm_GdkPropertyDataFromUVector(ScmObj uvec, int *format, /* out */ int *nelements); /* out */ /* * Arrays of primitive types */ typedef struct ScmGdkPointVectorRec { SCM_HEADER; int size; GdkPoint *elements; } ScmGdkPointVector; SCM_CLASS_DECL(Scm_GdkPointVectorClass); #define SCM_CLASS_GDK_POINT_VECTOR (&Scm_GdkPointVectorClass) #define SCM_GDK_POINT_VECTOR_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GDK_POINT_VECTOR) #define SCM_GDK_POINT_VECTOR(obj) ((ScmGdkPointVector*)(obj)) extern ScmObj Scm_MakeGdkPointVector(GdkPoint *pts, int npts); typedef struct ScmGdkSegmentVectorRec { SCM_HEADER; int size; GdkSegment *elements; } ScmGdkSegmentVector; SCM_CLASS_DECL(Scm_GdkSegmentVectorClass); #define SCM_CLASS_GDK_SEGMENT_VECTOR (&Scm_GdkSegmentVectorClass) #define SCM_GDK_SEGMENT_VECTOR_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GDK_SEGMENT_VECTOR) #define SCM_GDK_SEGMENT_VECTOR(obj) ((ScmGdkSegmentVector*)(obj)) extern ScmObj Scm_MakeGdkSegmentVector(GdkSegment *segs, int nsegs); typedef struct ScmGdkRectangleVectorRec { SCM_HEADER; int size; GdkRectangle *elements; } ScmGdkRectangleVector; SCM_CLASS_DECL(Scm_GdkRectangleVectorClass); #define SCM_CLASS_GDK_RECTANGLE_VECTOR (&Scm_GdkRectangleVectorClass) #define SCM_GDK_RECTANGLE_VECTOR_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GDK_RECTANGLE_VECTOR) #define SCM_GDK_RECTANGLE_VECTOR(obj) ((ScmGdkRectangleVector*)(obj)) extern ScmObj Scm_MakeGdkRectangleVector(GdkRectangle *rects, int nrects); typedef struct ScmGdkColorVectorRec { SCM_HEADER; int size; GdkColor *elements; } ScmGdkColorVector; SCM_CLASS_DECL(Scm_GdkColorVectorClass); #define SCM_CLASS_GDK_COLOR_VECTOR (&Scm_GdkColorVectorClass) #define SCM_GDK_COLOR_VECTOR_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GDK_COLOR_VECTOR) #define SCM_GDK_COLOR_VECTOR(obj) ((ScmGdkColorVector*)(obj)) extern ScmObj Scm_MakeGdkColorVector(GdkColor *colors, int ncolors); /* * string-list <-> gchar** conversion */ extern gint Scm_GtkStringsToGcharArrays(ScmObj list, gchar ***chars); extern ScmObj Scm_GtkGcharArraysToStrings(gint count, gchar **chars); #include "gtk-lib.h" /* * ScmGtkRadioGroup - Scheme representation of the group of GtkRadio* */ /* * GtkRadioButton and GtkRadioMenuItem uses GSList to group them. * The list must be shared among all the group members. * We can get the group by gtk_radio_button_get_group etc., but it is * inherently a transient structure; when a member is added in front * of the list, the pointer to the old list doesn't reflect the entire * group (GTk internally updates the pointers of all group members * when the members of group change). Furthermore, the returned * GSList may be deallocated anytime when the button pointed by the first * element is removed from the group. Thus it is not appropriate * to expose the list directly to Scheme. * * Scheme-level radio group keeps a pointer to one of the * member of the group. Any radiobutton belongs to at most one * group, so logically they are equivalent. When the button is * removed from the group, the Scheme radiobutton group object is * updated to point one of the rest members when there are any. */ typedef struct ScmGtkRadioGroupRec { SCM_HEADER; ScmObj radio; /* GtkRadioButton or GtkRadioMenuItem or #f */ } ScmGtkRadioGroup; SCM_CLASS_DECL(Scm_GtkRadioGroupClass); #define SCM_CLASS_GTK_RADIO_GROUP (&Scm_GtkRadioGroupClass) #define SCM_GTK_RADIO_GROUP_P(obj) SCM_XTYPEP(obj, SCM_CLASS_GTK_RADIO_GROUP) #define SCM_GTK_RADIO_GROUP(obj) ((ScmGtkRadioGroup*)(obj)) extern ScmObj Scm_MakeGtkRadioGroup(GObject *radio); extern ScmObj Scm_GtkRadioGroupToList(ScmGtkRadioGroup *group); extern GSList *Scm_GtkRadioGroupGetGroup(ScmObj group); /* mmc: gunichar: */ #define Scm_gunichar2char(x) SCM_MAKE_CHAR(Scm_UcsToChar(x)) #define Scm_char2gunichar(x) Scm_CharToUcs(SCM_CHAR_VALUE(x)) /* Generated: */ typedef struct ScmGSignalQueryRec { SCM_HEADER; GSignalQuery *data; ScmString *name; } ScmGSignalQuery; SCM_CLASS_DECL(Scm_GSignalQuery_Class); #define SCM_CLASS_G_SIGNAL_QUERY (&Scm_GSignalQuery_Class) #define SCM_G_SIGNAL_QUERY_P(obj) (Scm_TypeP(obj, SCM_CLASS_G_SIGNAL_QUERY)) #define SCM_G_SIGNAL_QUERY(obj) ((GSignalQuery*) (((ScmGSignalQuery*) obj)->data)) extern ScmObj Scm_Make_GSignalQuery(GSignalQuery *data); extern int gtk_trace_references; /* fixme: gauche_gtk_ */ extern void dump_referenced_gobjects(); ScmObj Scm_g_signal_emit(ScmObj destination, int signal_id, int detail, ScmObj params); void gauche_gdk_pixbuf_format_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx); SCM_DECL_END #endif /*GAUCHE_GTK_H*/ gauche-gtk-0.6+git20160927/src/gdk-lib.hints000066400000000000000000001112141300401456300201530ustar00rootroot00000000000000;; ;; Auxiliary stuff for autogenerating stub files. ;; If you edit this file, you have to regenerate stub files by h2stub.scm ;; ;; $Id: gdk-lib.hints,v 1.28 2007/01/13 01:36:31 maruska Exp $ ;; ;;================================================================== ;; gdk.h ;; (input-file "gdk.h") (define-cproc-fix gdk-init (fix-arguments! '(args)) (fix-body! "gint argc; gchar **argv; argc = Scm_GtkStringsToGcharArrays(args, &argv); gdk_init(&argc, &argv); SCM_RETURN(Scm_GtkGcharArraysToStrings(argc, argv));")) (define-cproc-fix gdk-init-check (fix-arguments! '(args)) (fix-body! "gint argc; gchar **argv; gboolean r; argc = Scm_GtkStringsToGcharArrays(args, &argv); r = gdk_init_check(&argc, &argv); if (r) SCM_RETURN(Scm_GtkGcharArraysToStrings(argc, argv)); else SCM_RETURN(SCM_FALSE);")) (define-cproc-fix gdk-set-locale (fix-arguments! '(args)) (fix-body! "gchar *locale = gdk_set_locale(); ScmObj s = SCM_MAKE_STR_COPYING((char*)locale); g_free(locale); SCM_RETURN(s);")) (define-cproc-fix gdk-get-display (fix-body! "gchar *display = gdk_get_display(); ScmObj s = SCM_MAKE_STR_COPYING((char*)display); g_free(display); SCM_RETURN(SCM_MAKE_STR_COPYING(display));")) ;; gdk-parse-args : no need if app uses high-level init API. Prohibit for now. (disable-cproc gdk-parse-args) ;; These are deprecated. (disable-cproc gdk-input-add-full) (disable-cproc gdk-input-add) (disable-cproc gdk-input-remove) ;; gdk_wcstombs and gdk_mbstowcs : we can use string->u32vector and vice versa. (disable-cproc gdk-wcstombs) (disable-cproc gdk-mbstowcs) ;; We prohibit these from Scheme for now. (disable-cproc gdk-threads-enter) (disable-cproc gdk-threads-leave) (disable-cproc gdk-threads-init) ;;================================================================== ;; gdkcolor.h ;; (input-file "gdkcolor.h") (define-cproc-fix gdk-color-parse (fix-arguments! '(spec::)) (fix-body! "GdkColor c; int r; r = gdk_color_parse(CONST_GCHAR_PTR(spec), &c); if (r) SCM_RETURN(Scm_MakeGdkColor(&c)); else SCM_RETURN(SCM_FALSE);")) ;; gdk-colormap-alloc-colors - deal with GdkColor array (define-cproc-fix gdk-colormap-alloc-colors (fix-arguments! '(colormap:: colors:: writable:: best_match::)) (fix-body! "gboolean success = FALSE; gint r; r = gdk_colormap_alloc_colors(colormap, colors->elements, colors->size, writable, best_match, &success); SCM_RETURN2(Scm_MakeInteger(r), SCM_MAKE_BOOL(success));") ) ;; gdk-colormap-free-colors - handle GdkColor array (define-cproc-fix gdk-colormap-free-colors (fix-arguments! '(colormap:: colors::)) (fix-body! "gdk_colormap_free_colors(colormap, colors->elements, colors->size); SCM_RETURN(SCM_UNDEFINED);") ) ;; gdk-color-free (disable-cproc gdk-color-free) ;; gdk-color-hash (define-cproc-fix gdk-color-hash (fix-arguments! '(colora::))) ;; gdk-color-equal (define-cproc-fix gdk-color-equal (set! (return-type-of self) (find-type 'gboolean)) (fix-arguments! '(colora:: colorb::))) (define-cproc-fix gdk-colormap-query-color (fix-arguments! '(colormap:: pixel::)) ;fixme: should be ;; (return "gdk_colormap_query_color")) (fix-body! "GdkColor result; gdk_colormap_query_color( colormap, pixel, &result); SCM_RETURN(Scm_MakeGdkColor(&result));")) ;; deprecated procedures (disable-cproc gdk-colors-store) (disable-cproc gdk-colors-alloc) (disable-cproc gdk-colors-free) (disable-cproc gdk-color-white) (disable-cproc gdk-color-black) (disable-cproc gdk-color-alloc) (disable-cproc gdk-color-change) ;;================================================================== ;; gdkdisplay.h ;; (input-file "gdkdisplay.h") (define-cclass-fix (set! (c-caster-of self) "GDK_DISPLAY_OBJECT")) (define-cproc-fix gdk-display-list-devices (fix-body! "GList *devices = gdk_display_list_devices(display); ScmObj r = Scm_GoListToList(devices); g_list_free(devices); SCM_RETURN(r);")) (define-cproc-fix gdk-display-get-pointer (fix-arguments! '(display::)) (fix-body! "GdkScreen *scr; gint x, y; GdkModifierType mod; gdk_display_get_pointer(display, &scr, &x, &y, &mod); SCM_RETURN4(SCM_MAKE_GDK_SCREEN(scr), Scm_MakeInteger(x), Scm_MakeInteger(y), Scm_MakeInteger(mod));")) (define-cproc-fix gdk-display-get-window-at-pointer (fix-arguments! '(display::)) (fix-body! "GdkWindow *win; gint x, y; win = gdk_display_get_window_at_pointer(display, &x, &y); if (win) { SCM_RETURN3(SCM_MAKE_GDK_WINDOW_OBJECT(win), Scm_MakeInteger(x), Scm_MakeInteger(y)); } else { SCM_RETURN3(SCM_FALSE, SCM_MAKE_INT(0), SCM_MAKE_INT(0)); }")) ;;================================================================== ;; gdkdnd.h ;; (input-file "gdkdnd.h") ;; - deal with GList* field ;; gdk_drag_get_protocol - returns two values, status code and drag protocol (define-cproc-fix gdk-drag-get-protocol (fix-arguments! '(xid::)) (fix-body! "GdkDragProtocol proto; guint32 retval; retval = gdk_drag_get_protocol(xid, &proto); SCM_RETURN2(Scm_MakeIntegerU(retval), Scm_MakeInteger(proto));")) ;; gdk_drag_find-window - returns two values, dest_window and protocol (define-cproc-fix gdk-drag-find-window (fix-arguments! '(context:: drag-window:: x-root:: y-root::)) (fix-body! "GdkWindow *dest; GdkDragProtocol proto; gdk_drag_find_window(context, drag_window, x_root, y_root, &dest, &proto); if (dest == NULL) SCM_RETURN2(SCM_FALSE, SCM_FALSE); else SCM_RETURN2(SCM_MAKE_GDK_DRAWABLE(dest), Scm_MakeInteger(proto));")) ;;================================================================== ;; gdkdrawable.h ;; (input-file "gdkdrawable.h") (define-cproc-fix gdk-drawable-get-size (fix-arguments! '(drawable::)) (fix-body! "gint w, h; gdk_drawable_get_size(drawable, &w, &h); SCM_RETURN2(SCM_MAKE_INT(w), SCM_MAKE_INT(h));") ) ;; gdk-drawable-set-data - not available from Scheme ;; gdk-drawable-get-data - not available from Scheme (disable-cproc gdk-drawable-set-data) (disable-cproc gdk-drawable-get-data) ;; gdk-draw-polygon - uses array of gdk-point (define-cproc-fix gdk-draw-polygon (fix-arguments! '(drawable:: gc:: filled ;; this must be boolean, but to keep backward ;; compatibility, we accept int as well. points::)) (fix-body! "GdkPoint *pts = points->elements; int npts = points->size; int filled_flag = (SCM_FALSEP(filled) || (SCM_EQ(filled, SCM_MAKE_INT(0))))? FALSE : TRUE; gdk_draw_polygon(drawable, gc, filled_flag, pts, npts); SCM_RETURN(SCM_UNDEFINED);")) ;; gdk-draw-string, gdk-draw-text, gdk-draw-text-wc : deprecated (disable-cproc gdk-draw-string) (disable-cproc gdk-draw-text) (disable-cproc gdk-draw-text-wc) ;; gdk-draw-points - use point array (define-cproc-fix gdk-draw-points (fix-arguments! '(drawable:: gc:: points::)) (fix-body! "GdkPoint *pts = points->elements; int npts = points->size; gdk_draw_points(drawable, gc, pts, npts); SCM_RETURN(SCM_UNDEFINED);")) ;; gdk-draw-segments - use segment array (define-cproc-fix gdk-draw-segments (fix-arguments! '(drawable:: gc:: segments::)) (fix-body! "GdkSegment *segs = segments->elements; int nsegs = segments->size; gdk_draw_segments(drawable, gc, segs, nsegs); SCM_RETURN(SCM_UNDEFINED);")) ;; gdk-draw-lines - use point array (define-cproc-fix gdk-draw-lines (fix-arguments! '(drawable:: gc:: points::)) (fix-body! "GdkPoint *pts = points->elements; int npts = points->size; gdk_draw_lines(drawable, gc, pts, npts); SCM_RETURN(SCM_UNDEFINED);")) ;; gdk-draw-layout - PangoLayout* ;; gdk-draw-layout-with-colors - PangoLayout* ;;================================================================== ;; gdkevents.h ;; (input-file "gdkevents.h") ;; these are C #defined (define-enum GDK_PRIORITY_EVENTS ) (define-enum GDK_PRIORITY_REDRAW ) ;; insert class to event subclass. (define-macro (gdk-event-fix class) `(define-cclass-fix ,class (set! (allocation-type-of self) 'indirect) (set! (superclass-of self) (find-type 'GdkEvent*)) (set! (cpl-of self) '("Scm_GdkEventClass")) (set! (allocator-of self) "return Scm_MakeGdkEvent((GdkEvent*)data);"))) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) (gdk-event-fix ) ;; GdkEventClient has union field. (define-cclass-fix (ignore-field! 'b) (ignore-field! 's) (ignore-field! 'l)) (disable-cproc gdk-event-copy) (disable-cproc gdk-event-free) ;; gdk-event-get-state - C API returns two information : a boolean value ;; whether event has a state field or not, and the actual value of the ;; state field if any. (define-cproc-fix gdk-event-get-state (fix-arguments! '(event::)) (fix-body! "GdkModifierType state = 0; gboolean r; r = gdk_event_get_state(event, &state); SCM_RETURN2(SCM_MAKE_BOOL(r), Scm_MakeIntegerU(state));")) ;; gdk_event_get_coords - returns three values; a flag whether the event ;; has coord info or not, and actual x and y coords. (define-cproc-fix gdk-event-get-coords (fix-arguments! '(event::)) (fix-body! "gdouble x = 0.0, y = 0.0; gboolean r; r = gdk_event_get_coords(event, &x, &y); SCM_RETURN3(SCM_MAKE_BOOL(r), Scm_MakeFlonum(x), Scm_MakeFlonum(y));")) ;; gdk_event_get_axis - returns two values. (define-cproc-fix gdk-event-get-axis (fix-arguments! '(event:: axis-use::)) (fix-body! "gdouble axis = 0.0; gboolean r; r = gdk_event_get_axis(event, axis_use, &axis); SCM_RETURN2(SCM_MAKE_BOOL(r), Scm_MakeFlonum(axis));")) (define-cproc-fix gdk-event-get-root-coords (fix-arguments! '(event::)) (fix-body! "gdouble x = 0.0, y = 0.0; gboolean r; r = gdk_event_get_root_coords(event, &x, &y); if (r) { SCM_RETURN2(Scm_MakeFlonum(x), Scm_MakeFlonum(y)); } else { SCM_RETURN2(SCM_FALSE, SCM_FALSE); }")) ;; gdk-event-handler-set - fix callback ;; gdk-add-client-message-filter - fix callback (define-cproc-fix gdk-setting-get (fix-arguments! '(name::)) (fix-body! "GValue gv; ScmObj r; gv.g_type = 0; gdk_setting_get(name, &gv); r = Scm_UnboxGValue(&gv); g_value_unset(&gv); SCM_RETURN(r);")) ;;================================================================== ;; gdkfont.h - deprecated ;; (input-file "gdkfont.h") (disable-cproc gdk-font-load) (disable-cproc gdk-fontset-load) (disable-cproc gdk-string-width) (disable-cproc gdk-text-width) (disable-cproc gdk-text-width-wc) (disable-cproc gdk-text-measure) (disable-cproc gdk-text-height) (disable-cproc gdk-char-width) (disable-cproc gdk-char-width-wc) (disable-cproc gdk-char-measure) (disable-cproc gdk-char-height) (disable-cproc gdk-text-extents) (disable-cproc gdk-text-extents-wc) (disable-cproc gdk-string-extents) (disable-cproc gdk-font-full-name-get) (disable-cproc gdk-font-full-name-free) ;;================================================================== ;; gdkgc.h ;; (input-file "gdkgc.h") (define-cproc-fix gdk-gc-new-with-values (fix-arguments! '(drawable:: values:: mask::)) (fix-body! "SCM_RETURN(SCM_MAKE_GDK_GC(gdk_gc_new_with_values(drawable, values, mask)));") ) (define-cproc-fix gdk-gc-get-values (fix-arguments! '(gc::)) (fix-body! "GdkGCValues values; gdk_gc_get_values(gc, &values); SCM_RETURN(Scm_MakeGdkGCValues(&values));") ) ;; gdk_gc_set_dashes - use u8vector for dash_list[]; for now, disable (disable-cproc gdk-gc-set-dashes) ;; gdk_gc_copy - disable for now (disable-cproc gdk-gc-copy) ;;================================================================== ;; gdkimage.h ;; (input-file "gdkimage.h") ;; gdk_image_new_bitmap - need to handle opaque pointer data. (disable-cproc gdk-image-new-bitmap) ;;================================================================== ;; gdkinput.h ;; (input-file "gdkinput.h") ;; struct GdkDevice - need to handle gchar* slot ;; gdk_device_get_state - returns two values (define-cproc-fix gdk-device-get-state (fix-arguments! '(device:: window::)) (fix-body! "int naxis = device->num_axes; GdkModifierType mask; ScmF64Vector *axes = SCM_F64VECTOR(Scm_MakeF64Vector(naxis, 0.0)); gdk_device_get_state(device, window, SCM_F64VECTOR_ELEMENTS(axes), &mask); SCM_RETURN2(SCM_OBJ(axes), Scm_MakeIntegerU(mask));")) ;; gdk_device_get_history - the first return value is a boolean value ;; indicating wheather the history is available or not. The second return ;; value is a list of timestamps, and the third return value is a vector ;; of axis values of length Na x Nt, where Na is the number of axis and ;; Nt is the number of timestamps. Axis number na of timestamp t can be ;; accessed as (t * Na) + na -th element of the vector. If the history ;; info is not available, the second return value is '() and the third is #f. (define-cproc-fix gdk-device-get-history (fix-arguments! '(device:: window:: start:: stop::)) (fix-body! "GdkTimeCoord **events; gint nevents, i, j, naxes; gboolean r; ScmF64Vector *v; ScmObj h = SCM_NIL, t = SCM_NIL; r = gdk_device_get_history(device, window, start, stop, &events, &nevents); if (!r) SCM_RETURN3(SCM_FALSE, SCM_NIL, SCM_FALSE); naxes = device->num_axes; v = SCM_F64VECTOR(Scm_MakeF64Vector(nevents * naxes, 0.0)); for (i=0; itime)); for (j=0; jaxes[j]; } } gdk_device_free_history(events, nevents); SCM_RETURN3(SCM_TRUE, h, SCM_OBJ(v));") ) ;; gdk_device_free_history - not necessary (disable-cproc gdk-device-free-history) ;; gdk_device_get_axis - takes an optional argument offset, which ;; may specify an offset of axes value array; useful to extract ;; a specific record out of the long vector returned from ;; gdk-device-get-history. Returns two values; boolean and the value. (define-cproc-fix gdk-device-get-axis (fix-arguments! '(device:: axes:: use:: &optional offset::)) (fix-body! "gdouble *aptr = (gdouble*)(SCM_F64VECTOR_ELEMENTS(axes)+offset); gboolean r; gdouble value = 0.0; r = gdk_device_get_axis(device, aptr, use, &value); SCM_RETURN2(SCM_MAKE_BOOL(r), Scm_MakeFlonum(value));") ) (define-cproc-fix gdk-devices-list (fix-arguments! '()) (fix-body! "GList *devices = gdk_devices_list(); ScmObj r = Scm_GoListToList(devices); g_list_free(devices); SCM_RETURN(r);")) ;;================================================================== ;; gdkkeys.h ;; (input-file "gdkkeys.h") ;; gdk_keymap_lookup_key (define-cproc-fix gdk-keymap-lookup-key (fix-arguments! '(keymap:: key::))) ;; gdk_keymap_translate_keyboard_state returns five values (define-cproc-fix gdk-keymap-translate-keyboard-state (fix-arguments! '(keymap:: hardware_keycode:: state:: group::)) (fix-body! "guint keyval; gint effective_group, level; GdkModifierType consumed_modifiers; gboolean r; r = gdk_keymap_translate_keyboard_state(keymap, hardware_keycode, state, group, &keyval, &effective_group, &level, &consumed_modifiers); SCM_RETURN5(SCM_MAKE_BOOL(r), Scm_MakeIntegerU(keyval), Scm_MakeInteger(effective_group), Scm_MakeInteger(level), Scm_MakeIntegerU(consumed_modifiers));")) ;; gdk_keymap_get_entries_for_keyval - to do ;; gdk_keymap_get_entries_for_keycode - to do ;; gdk_keyval_name (define-cproc-fix gdk-keyval-name (fix-body! "gchar* r = gdk_keyval_name(keyval); SCM_RETURN(SCM_MAKE_STR(r));")) ;; gdk_keyval_convert_case - returns two values (define-cproc-fix gdk-keyval-convert-case (fix-arguments! '(symbol::)) (fix-body! "guint lower, upper; gdk_keyval_convert_case(symbol, &lower, &upper); SCM_RETURN2(Scm_MakeIntegerU(lower), Scm_MakeIntegerFromUI(upper));")) ;;================================================================== ;; gdkpango.h ;; (input-file "gdkpango.h") ;; gdk_pango_layout_line_get_clip_region ;; gdk_pango_layout_get_clip_region ;;================================================================== ;; gdkpixbuf.h ;; (input-file "gdkpixbuf.h") (define-opaque GdkPixbuf :gobject) (define-opaque GdkPixbufAnimation :gobject) (define-opaque GdkPixbufAnimationIter :gobject) ;; gdk-pixbuf-io.h is not ready! (input-file "gdkpixbuf-io.h") ;; GDK_PIXBUF_ENABLE_BACKEND ;; Not Gobjects! ;(cclass-fix (disable-cclass ) ;(define-opaque GdkPixbufModulePattern :indirect) (disable-cclass ) ;(define-opaque GdkPixbufModule :indirect) ;(define-opaque GdkPixbufAnimationIter :gobject) ;;================================================================== ;; gdkpixmap.h ;; (input-file "gdkpixmap.h") ;; GdkPixmapObject uses macro names GDK_PIXMAP etc. (define-cclass-fix (set! (gtk-predicate-of self) "GDK_IS_PIXMAP") (set! (gtk-type-name-of self) "GDK_TYPE_PIXMAP")) (define-cproc-fix gdk-pixmap-create-from-xpm (fix-arguments! '(window:: transparent_color::-or-null filename::)) (fix-body! "GdkBitmap *mask; GdkDrawable *d = gdk_pixmap_create_from_xpm(window, &mask, transparent_color, filename); SCM_RETURN2(SCM_MAKE_GDK_DRAWABLE(d), SCM_MAKE_GDK_DRAWABLE(mask));")) (define-cproc-fix gdk-pixmap-colormap-create-from-xpm (fix-arguments! '(window:: colormap::-or-null transparent_color::-or-null filename::)) (fix-body! "GdkBitmap *mask; GdkDrawable *d = gdk_pixmap_colormap_create_from_xpm(window, colormap, &mask, transparent_color, filename); SCM_RETURN2(SCM_MAKE_GDK_DRAWABLE(d), SCM_MAKE_GDK_DRAWABLE(mask));")) (define-cproc-fix gdk-pixmap-create-from-xpm-d (fix-arguments! '(window:: transparent_color::-or-null data::)) (fix-body! "gchar **dat = (gchar**)Scm_StringListToStringArray(data); GdkBitmap *mask; GdkDrawable *d = gdk_pixmap_create_from_xpm_d(window, &mask, transparent_color, dat); SCM_RETURN2(SCM_MAKE_GDK_DRAWABLE(d), SCM_MAKE_GDK_DRAWABLE(mask));")) (define-cproc-fix gdk-pixmap-colormap-create-from-xpm-d (fix-arguments! '(window:: colormap::-or-null transparent_color::-or-null data::)) (fix-body! "gchar **dat = (gchar**)Scm_StringListToStringArray(data); GdkBitmap *mask; GdkDrawable *d = gdk_pixmap_colormap_create_from_xpm_d(window, colormap, &mask, transparent_color, dat); SCM_RETURN2(SCM_MAKE_GDK_DRAWABLE(d), SCM_MAKE_GDK_DRAWABLE(mask));")) ;; gdk-pixmap-foreign-new ;; gdk-pixmap-lookup ;;================================================================== ;; gdkrgb.h ;; (input-file "gdkrgb.h") (define-cproc-fix gdk-draw-rgb-image (fix-arguments! '(drawable:: gc:: x:: y:: width:: height:: dith:: buf:: rowstride::)) (fix-body! "if (SCM_U8VECTOR_SIZE(buf) < (rowstride*(height-1)+width)*3) { Scm_Error(\"image data is too small: %S\", buf); } gdk_draw_rgb_image(drawable, gc, x, y, width, height, dith, (guchar*)SCM_U8VECTOR_ELEMENTS(buf), rowstride); SCM_RETURN(SCM_UNDEFINED);")) (define-cproc-fix gdk-draw-rgb-image-dithalign (fix-arguments! '(drawable:: gc:: x:: y:: width:: height:: dith:: buf:: rowstride:: xdith:: ydith::)) (fix-body! "if (SCM_U8VECTOR_SIZE(buf) < (rowstride*(height-1)+width)*3) { Scm_Error(\"image data is too small: %S\", buf); } gdk_draw_rgb_image_dithalign(drawable, gc, x, y, width, height, dith, (guchar*)SCM_U8VECTOR_ELEMENTS(buf), rowstride, xdith, ydith); SCM_RETURN(SCM_UNDEFINED);")) (define-cproc-fix gdk-draw-rgb-32-image (fix-arguments! '(drawable:: gc:: x:: y:: width:: height:: dith:: buf:: rowstride::)) (fix-body! "if (SCM_U8VECTOR_SIZE(buf) < (rowstride*(height-1)+width)*4) { Scm_Error(\"image data is too small: %S\", buf); } gdk_draw_rgb_32_image(drawable, gc, x, y, width, height, dith, (guchar*)SCM_U8VECTOR_ELEMENTS(buf), rowstride); SCM_RETURN(SCM_UNDEFINED);")) (define-cproc-fix gdk-draw-rgb-32-image-dithalign (fix-arguments! '(drawable:: gc:: x:: y:: width:: height:: dith:: buf:: rowstride:: xdith:: ydith::)) (fix-body! "if (SCM_U8VECTOR_SIZE(buf) < (rowstride*(height-1)+width)*4) { Scm_Error(\"image data is too small: %S\", buf); } gdk_draw_rgb_32_image_dithalign(drawable, gc, x, y, width, height, dith, (guchar*)SCM_U8VECTOR_ELEMENTS(buf), rowstride, xdith, ydith); SCM_RETURN(SCM_UNDEFINED);")) (define-cproc-fix gdk-draw-indexed-image (fix-arguments! '(drawable:: gc:: x:: y:: width:: height:: dith:: buf:: rowstride:: cmap::)) (fix-body! "if (SCM_U8VECTOR_SIZE(buf) < (rowstride*(height-1)+width)) { Scm_Error(\"image data is too small: %S\", buf); } gdk_draw_indexed_image(drawable, gc, x, y, width, height, dith, (guchar*)SCM_U8VECTOR_ELEMENTS(buf), rowstride, cmap); SCM_RETURN(SCM_UNDEFINED);")) (define-cproc-fix gdk-draw-gray-image (fix-arguments! '(drawable:: gc:: x:: y:: width:: height:: dith:: buf:: rowstride::)) (fix-body! "if (SCM_U8VECTOR_SIZE(buf) < (rowstride*(height-1)+width)) { Scm_Error(\"image data is too small: %S\", buf); } gdk_draw_gray_image(drawable, gc, x, y, width, height, dith, (guchar*)SCM_U8VECTOR_ELEMENTS(buf), rowstride); SCM_RETURN(SCM_UNDEFINED);")) (define-cproc-fix gdk-rgb-cmap-new (fix-arguments! '(colors::)) (fix-body! "guint32 *cols; int ncols; cols = SCM_U32VECTOR_ELEMENTS(colors); ncols = SCM_U32VECTOR_SIZE(colors); SCM_RETURN(SCM_MAKE_GDK_RGB_CMAP(gdk_rgb_cmap_new(cols, ncols)));")) ;;================================================================== ;; gdkregion.h ;; (input-file "gdkregion.h") (define-opaque GdkRegion :indirect) (define-cclass-fix (set! (c-free-proc-of self) "gdk_region_destroy")) (define-type "GdkRegion*" #f #f #f "SCM_MAKE_GDK_REGION") ;; gdk-region-polygon - use point array (define-cproc-fix gdk-region-polygon (fix-arguments! '(points:: fill-rule::)) (fix-body! "GdkPoint *pts = points->elements; int npts = points->size; SCM_RETURN(Scm_MakeGdkRegion(gdk_region_polygon(pts, npts, fill_rule)));")) ;; gdk-region-get-rectangles - use rectangle array (define-cproc-fix gdk-region-get-rectangles (fix-arguments! '(region::)) (fix-body! "GdkRectangle *rects; int nrects; ScmObj r; gdk_region_get_rectangles(region, &rects, &nrects); r = Scm_MakeGdkRectangleVector(rects, nrects); g_free(rects); SCM_RETURN(r);")) ;; gdk-region-spans-intersect-foreach - disable for now (disable-cproc gdk-region-spans-intersect-foreach) ;;================================================================== ;; gdkscreen.h ;; (input-file "gdkscreen.h") (define-cproc-fix gdk-screen-list-visuals (fix-body! "GList *vis = gdk_screen_list_visuals(screen); ScmObj r = Scm_GoListToList(vis); g_list_free(vis); SCM_RETURN(r);")) (define-cproc-fix gdk-screen-get-setting (fix-arguments! '(screen:: name::)) (fix-body! "GValue gv; ScmObj r; gv.g_type = 0; if (!gdk_screen_get_setting(screen, name, &gv)) { SCM_RETURN(SCM_FALSE); } r = Scm_UnboxGValue(&gv); g_value_unset(&gv); SCM_RETURN(r);")) (define-cproc-fix gdk-screen-get-toplevel-windows (fix-body! "GList *wins = gdk_screen_get_toplevel_windows(screen); ScmObj r = Scm_GoListToList(wins); g_list_free(wins); SCM_RETURN(r);")) ;;================================================================== ;; gdktypes.h ;; (input-file "gdktypes.h") ;;================================================================== ;; gdkvisual.h ;; (input-file "gdkvisual.h") (define-cproc-fix gdk-query-depths (fix-arguments! '()) (fix-body! "gint count, *depths; int i; ScmObj h = SCM_NIL, t = SCM_NIL; gdk_query_depths(&depths, &count); for (i=0; i)) (fix-body! "gint x, y, w, h, depth; gdk_window_get_geometry(window, &x, &y, &w, &h, &depth); SCM_RETURN5(Scm_MakeInteger(x), Scm_MakeInteger(y), Scm_MakeInteger(w), Scm_MakeInteger(h), Scm_MakeInteger(depth));")) (define-cproc-fix gdk-window-get-position (fix-arguments! '(window::)) (fix-body! "gint x, y; gdk_window_get_position(window, &x, &y); SCM_RETURN2(Scm_MakeInteger(x), Scm_MakeInteger(y));")) (define-cproc-fix gdk-window-get-origin (fix-arguments! '(window::)) (fix-body! "gint x, y; gdk_window_get_origin(window, &x, &y); SCM_RETURN2(Scm_MakeInteger(x), Scm_MakeInteger(y));")) (define-cproc-fix gdk-window-get-pointer (fix-arguments! '(window::)) (fix-body! "gint x, y; GdkModifierType mask; GdkDrawable *win; win = gdk_window_get_pointer(window, &x, &y, &mask); if (win) { SCM_RETURN4(SCM_MAKE_GDK_DRAWABLE(win), Scm_MakeInteger(x), Scm_MakeInteger(y), Scm_MakeInteger(mask)); } else { SCM_RETURN4(SCM_FALSE, SCM_FALSE, SCM_FALSE, SCM_FALSE); }")) (define-cproc-fix gdk-window-get-children (fix-body! "GList *lis = gdk_window_get_children(window); ScmObj r = Scm_GoListToList(lis); g_list_free(lis); SCM_RETURN(r);")) (define-cproc-fix gdk-window-peek-children (fix-body! "GList *lis = gdk_window_get_children(window); ScmObj r = Scm_GoListToList(lis); SCM_RETURN(r);")) (define-cproc-fix gdk-window-get-decorations (fix-arguments! '(window::)) (fix-body! "gboolean r; GdkWMDecoration d; r = gdk_window_get_decorations(window, &d); if (r) SCM_RETURN(Scm_MakeIntegerU(d)); else SCM_RETURN(SCM_FALSE);")) (define-cproc-fix gdk-window-get-toplevels (fix-body! "GList *lis = gdk_window_get_toplevels(); ScmObj r = Scm_GoListToList(lis); g_list_free(lis); SCM_RETURN(r);")) (define-cproc-fix gdk-window-constrain-size (fix-arguments! '(geometry:: flags:: width:: height::)) (fix-body! "gint neww, newh; gdk_window_constrain_size(geometry, flags, width, height, &neww, &newh); SCM_RETURN2(Scm_MakeInteger(neww), Scm_MakeInteger(newh));")) ;; mmc: [15 dic 05] -or-null is unknown? ;; gdkwindow (define-cproc-fix gdk-window-set-back-pixmap ;; -or-null (fix-arguments! '(window:: pixmap::-or-null parent_relative::) )) ;;================================================================== ;; gdk-pixbuf-features.h ;; (input-file "gdk-pixbuf-features.h") (define-enum GDK_PIXBUF_MAJOR) (define-enum GDK_PIXBUF_MINOR) (define-enum GDK_PIXBUF_MICRO) (define-constant GDK_PIXBUF_VERSION "SCM_MAKE_STR_IMMUTABLE(GDK_PIXBUF_VERSION)") ;;================================================================== ;; gdk-pixbuf.h ;; (input-file "gdk-pixbuf.h") ;; gdk-pixbuf-new (define-cproc-fix gdk-pixbuf-new-from-file (fix-arguments! '(filename::)) (fix-body! "GError *perr = NULL; GdkPixbuf *buf = gdk_pixbuf_new_from_file(filename, &perr); if (buf == NULL) { /* NB: should use subclass of according to the error domain */ Scm_Error(\"Pixbuf open failed: %s\", perr->message); }; ScmObj go = SCM_MAKE_GDK_PIXBUF(buf); #if 0 g_object_unref(buf); #endif SCM_RETURN(go);")) ;; gdk-pixbuf-get-pixels ;; gdk-pixbuf-new-from-data ;; gdk_pixbuf_new_from_xpm_data ;; gdk_pixbuf_new_from_inline (define-cproc-fix gdk-pixbuf-save (fix-arguments! '(pixbuf:: filename:: type:: &rest options)) (fix-body! "GError *perr = NULL; char **opt_keys, **opt_vals; int optcount = Scm_Length(options); int i; gboolean r; if (optcount % 2) { Scm_Error(\"gdk-pixbuf-save: option list is not even: %S\", options); } optcount /= 2; opt_keys = SCM_NEW_ATOMIC2(char**, sizeof(char*)*(optcount+1)); opt_vals = SCM_NEW_ATOMIC2(char**, sizeof(char*)*(optcount+1)); for (i=0; i according to the error domain */ Scm_Error(\"Pixbuf save failed: %s\", perr->message); } SCM_RETURN(SCM_TRUE);")) (define-cproc-fix gdk-pixbuf-animation-new-from-file (fix-arguments! '(filename::)) (fix-body! "GError *perr = NULL; GdkPixbufAnimation *buf = gdk_pixbuf_animation_new_from_file(filename, &perr); if (buf == NULL) { /* NB: should use subclass of according to the error domain */ Scm_Error(\"Pixbuf open failed: %s\", perr->message); } SCM_RETURN(SCM_MAKE_GDK_PIXBUF_ANIMATION(buf));")) ;; The time value should be