gauche-gtk-0.5/0000755000175100017510000000000012077174732012665 5ustar gniibegniibegauche-gtk-0.5/Makefile.in0000644000175100017510000000416112077172161014726 0ustar gniibegniibeSHELL = @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.5/todo0000644000175100017510000000223112077172161013545 0ustar gniibegniibe * Examples for new features: - gtk-container-get-children - gtk-container-child-get-property - gtk-check-version - gtk-combo-box-get-active-text - gtk-widget-get-child-requisition - gtk-widget-get-composite-name - gtk-rc-set-default-files - gtk-rc-get-default-files - gtk-ui-manager-add-ui-from-file - gdk pixbuf loader! gdk-pixbuf-loader-write gdk-pixbuf-loader-close * Emitting signals! - g-signal-emit * debugging support: - dump-referenced-gobjects - tree view: gtk-cell-set-color gtk-tree-view-column-set-cell-data-func * fixme: This depends on my gtk+ patches! gtk-pixbuf-render-set-lazy-loader * handy? gtk-box-query-child-packing gtk-box-set-child-packing gtk-list-store-insert-with-values * `write' method for gdk-pixbuf-format should print the format name! how come ? WARNING: allocating instance of class #>: coresize argument 24 doesn't match the class definition's (16) WARNING: allocating instance of class #>: coresize argument 24 doesn't match the class definition's (16) I installed a different ABI gauche-gtk. when using the old-ABI base gauche-gtksourceview. gauche-gtk-0.5/DIST_EXCLUDE0000644000175100017510000000007312077172161014516 0ustar gniibegniibeAUTOCONF DIST DIST_EXCLUDE DIST_EXCLUDE_X INSTALL.esc .git gauche-gtk-0.5/DIST0000755000175100017510000000242112077172161013347 0ustar gniibegniibe#!/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.5/lib/0000755000175100017510000000000012077172161013425 5ustar gniibegniibegauche-gtk-0.5/lib/Makefile.in0000644000175100017510000000234212077172161015473 0ustar gniibegniibe.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.5/lib/gtk.scm0000644000175100017510000000207012077172161014715 0ustar gniibegniibe;;; ;;; 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.charconv) ) (select-module gtk) (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! (provide "gtk") gauche-gtk-0.5/lib/h2s/0000755000175100017510000000000012077172161014121 5ustar gniibegniibegauche-gtk-0.5/lib/h2s/track.scm0000644000175100017510000000423012077172161015730 0ustar gniibegniibe ;; 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.5/lib/h2s/parse.scm0000644000175100017510000004033612077172161015745 0ustar gniibegniibe(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. (#/^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.5/lib/h2s/program.scm0000644000175100017510000000053612077172161016300 0ustar gniibegniibe ;; 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.5/lib/h2s/gtk-types-for-emit.scm0000644000175100017510000000123512077172161020275 0ustar gniibegniibe (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.5/lib/h2s/utils.scm0000644000175100017510000000336512077172161015774 0ustar gniibegniibe;; 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.5/lib/h2s/objects.scm0000644000175100017510000000535712077172161016270 0ustar gniibegniibe ;;;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.5/lib/h2s/lookup.scm0000644000175100017510000000107212077172161016136 0ustar gniibegniibe#! /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.5/lib/h2s/fixup.scm0000644000175100017510000003560112077172161015765 0ustar gniibegniibe ;; 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.5/lib/h2s/emit.scm0000644000175100017510000005337512077172161015600 0ustar gniibegniibe ;; 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.5/lib/h2s/top.scm0000644000175100017510000000751212077172161015434 0ustar gniibegniibe (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.5/lib/h2s/gtk-types.scm0000644000175100017510000003175612077172161016570 0ustar gniibegniibe ;; 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.5/lib/h2s/gtk-types-for-fixup.scm0000644000175100017510000000144412077172161020474 0ustar gniibegniibe ;; 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.5/lib/gtk/0000755000175100017510000000000012077172161014212 5ustar gniibegniibegauche-gtk-0.5/lib/gtk/error-dialog.scm0000644000175100017510000000443312077172161017310 0ustar gniibegniibe;;; ;;; 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 (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)) (vm-set-default-exception-handler (current-thread) report-error)) (provide "gtk/error-dialog") gauche-gtk-0.5/lib/gtk/gtkaux.scm0000644000175100017510000000401712077172161016223 0ustar gniibegniibe;;; ;;; 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))) (provide "gtk/gtkaux") gauche-gtk-0.5/lib/gtk/glgd.scm0000644000175100017510000000731512077172161015641 0ustar gniibegniibe;;; ;;; 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" (lambda (w . _) (glgd-graph-fini (ref self 'graph)))) (g-signal-connect self "realize" (lambda (w . _) (with-gtkgl-context self gtk-graph-area-initialize))) (g-signal-connect self "configure_event" (lambda (w . _) (with-gtkgl-context self gtk-graph-area-configure))) (g-signal-connect self "expose_event" (lambda (w . _) (with-gtkgl-context self gtk-graph-area-draw))) (g-signal-connect self "map_event" (lambda (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) (let ((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) (provide "gtk/glgd") gauche-gtk-0.5/lib/gtk/listener.scm0000644000175100017510000000305512077172161016546 0ustar gniibegniibe;;; ;;; 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))) (provide "gtk/listener") gauche-gtk-0.5/lib/gtk/gtkgl.scm0000644000175100017510000000215212077172161016026 0ustar gniibegniibe;;; ;;; 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)))) (provide "gtk/gtkgl") gauche-gtk-0.5/lib/gen-keysyms.scm0000644000175100017510000000146312077172161016410 0ustar gniibegniibe;; ;; 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.5/ChangeLog0000644000175100017510000000230312077172161014427 0ustar gniibegniibe2012-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.5/README0000644000175100017510000001377012077172161013547 0ustar gniibegniibeThis 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.5/src/0000755000175100017510000000000012077174732013454 5ustar gniibegniibegauche-gtk-0.5/src/Makefile.in0000644000175100017510000000661712077174351015530 0ustar gniibegniibe# # 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.5/src/gdk-lib.hints0000644000175100017510000011121412077172161016026 0ustar gniibegniibe;; ;; 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