Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv31410/src

Modified Files: bindings.lisp enums.lisp gtkbindings.lisp gtkclasshierarchy.lisp gtkenums.lisp gtklisp.lisp gtknexus.lisp Log Message: Fixed a few things, and added a bit of gtk functionality.

Date: Wed Nov 5 12:49:56 2003 Author: mmommer

Index: lgtk/src/bindings.lisp diff -u lgtk/src/bindings.lisp:1.1.1.1 lgtk/src/bindings.lisp:1.2 --- lgtk/src/bindings.lisp:1.1.1.1 Mon Oct 27 14:14:50 2003 +++ lgtk/src/bindings.lisp Wed Nov 5 12:49:56 2003 @@ -8,7 +8,8 @@ ;; Facilities for making bindings. Essentially an FFI interface. (defpackage #:defbinding (:export #:def-binding #:def-bindings-types #:def-raw-binding - #:set-aliens-package #:def-binding-type) + #:set-aliens-package #:def-binding-type + #:in-filter #:out-filter #:alien-type) (:use common-lisp clnexus-port))

(in-package #:defbinding)

Index: lgtk/src/enums.lisp diff -u lgtk/src/enums.lisp:1.1.1.1 lgtk/src/enums.lisp:1.2 --- lgtk/src/enums.lisp:1.1.1.1 Mon Oct 27 14:14:51 2003 +++ lgtk/src/enums.lisp Wed Nov 5 12:49:56 2003 @@ -8,7 +8,7 @@ ;;; An FFI enhancement for C enums (defpackage #:enums (:export #:defenum #:translate) - (:use :common-lisp)) + (:use :common-lisp :defbinding))

(in-package #:enums)

@@ -134,4 +134,8 @@ (defmacro ,name (,arg) `(translated-form ,,symb ,,arg ,',name ,',(if bitwise '((:optor . logior) - (:optand . logand)))))))) + (:optand . logand))))) + + (def-binding-type ,name + :in ',name + :alien :int))))

Index: lgtk/src/gtkbindings.lisp diff -u lgtk/src/gtkbindings.lisp:1.2 lgtk/src/gtkbindings.lisp:1.3 --- lgtk/src/gtkbindings.lisp:1.2 Fri Oct 31 05:52:52 2003 +++ lgtk/src/gtkbindings.lisp Wed Nov 5 12:49:56 2003 @@ -33,27 +33,27 @@

(def-bindings-types

- (gtkobject - :in 'contents-nil - :out 'gtkocapsule - :alien '(* t)) +; (gtkobject +; :in 'contents-nil +; :out 'gtkocapsule +; :alien '(* t))

(gslist :in 'contents-nil :out 'gslist-encap :alien '(* t))

- (gtkwindowtype - :in 'gtkwindowtype - :alien :int) - - (gtkattachoptions - :in 'gtkattachoptions - :alien :int) - - (gtkpositiontype - :in 'gtkpositiontype - :alien :int) +; (gtkwindowtype +; :in 'gtkwindowtype +; :alien :int) + +; (gtkattachoptions +; :in 'gtkattachoptions +; :alien :int) + +; (gtkpositiontype +; :in 'gtkpositiontype +; :alien :int)

(c-string :alien :c-string) @@ -105,6 +105,24 @@ (def-binding "gtk_label_new" (gtklabel (c-string i)))

+(def-binding "gtk_label_new_with_mnemonic" + (gtklabel (c-string i))) + +(def-binding "gtk_label_set_text" + (void (gtklabel label) + (c-string i))) + +(def-binding "gtk_label_get_text" + (c-string (gtklabel label))) + +(def-binding "gtk_label_set_justify" + (void (gtklabel l) + (gtkjustification j))) + +(def-binding "gtk_label_set_line_wrap" + (void (gtklabel label) + (gboolean wrap))) + (def-binding "gtk_button_new" (gtkbutton))

@@ -165,6 +183,24 @@ (void (gtktogglebutton wid) (gboolean active)))

+(def-binding "gtk_arrow_new" + (GtkWidget (GtkArrowType arrow_type) + (GtkShadowType shadow_type))) + +(def-binding "gtk_arrow_set" + (void (GtkArrow arrow) + (GtkArrowType arrow_type) + (GtkShadowType shadow_type ))) + +(def-binding "gtk_tooltips_new" + (GtkTooltips)) + +(def-binding "gtk_tooltips_set_tip" + (void (GtkTooltips tooltips) + (GtkWidget widget) + (c-string tip_text) + (c-string tip_private))) + (def-binding "gtk_table_new" (gtktable (guint rows) (guint columns) @@ -193,6 +229,9 @@ (def-binding "gtk_widget_show" (void (gtkwidget w)))

+(def-binding "gtk_widget_show_all" + (void (gtkwidget w))) + (def-binding "gtk_widget_set_size_request" (void (gtkwidget w) (gint width) @@ -346,6 +385,9 @@ (def-raw-binding "g_signal_handler_disconnect" (void (voidptr instance) (guint id))) + +(def-raw-binding "g_object_unref" + (void (voidptr unref)))

(def-raw-binding "gtk_timeout_add" (guint (guint interval)

Index: lgtk/src/gtkclasshierarchy.lisp diff -u lgtk/src/gtkclasshierarchy.lisp:1.2 lgtk/src/gtkclasshierarchy.lisp:1.3 --- lgtk/src/gtkclasshierarchy.lisp:1.2 Fri Oct 31 05:52:52 2003 +++ lgtk/src/gtkclasshierarchy.lisp Wed Nov 5 12:49:56 2003 @@ -38,6 +38,12 @@ :initarg :meta :initform (find-class 'gtk-objmeta))))

+(defclass g-objmeta (metawidget) ()) +(defclass g-objcapsule (widcapsule) + ((meta :accessor meta + :initarg :meta + :initform (find-class 'g-objmeta)))) + ;;; ;;; Here we import the complete gtk class hierarchy. ;;; @@ -169,4 +175,3 @@

;; engage. (make-gtk-object-hierarchy)) -

Index: lgtk/src/gtkenums.lisp diff -u lgtk/src/gtkenums.lisp:1.1.1.1 lgtk/src/gtkenums.lisp:1.2 --- lgtk/src/gtkenums.lisp:1.1.1.1 Mon Oct 27 14:14:55 2003 +++ lgtk/src/gtkenums.lisp Wed Nov 5 12:49:56 2003 @@ -44,3 +44,22 @@ :gtk-pos-right :gtk-pos-top :gtk-pos-bottom)) + +(defenum gtkjustification + (:gtk-justify-left + :gtk-justify-right + :gtk-justify-center + :gtk-justify-fill)) + +(defenum gtkarrowtype + (:gtk-arrow-up + :gtk-arrow-down + :gtk-arrow-left + :gtk-arrow-right)) + +(defenum gtkshadowtype + (:gtk-shadow-none + :gtk-shadow-in + :gtk-shadow-out + :gtk-shadow-etched-in + :gtk-shadow-etched-out))

Index: lgtk/src/gtklisp.lisp diff -u lgtk/src/gtklisp.lisp:1.2 lgtk/src/gtklisp.lisp:1.3 --- lgtk/src/gtklisp.lisp:1.2 Fri Oct 31 05:52:52 2003 +++ lgtk/src/gtklisp.lisp Wed Nov 5 12:49:56 2003 @@ -124,6 +124,13 @@ gtkdestroy #'dummy-func))

+(defmethod initialize-instance :after ((it g-objcapsule) &key) + (g-signal-connect it + gtkdestroy ;; it should not be called like this. + #'dummy-func)) + + + ;; Initialize. (eval-when (:load-toplevel :execute :compile-toplevel)

Index: lgtk/src/gtknexus.lisp diff -u lgtk/src/gtknexus.lisp:1.2 lgtk/src/gtknexus.lisp:1.3 --- lgtk/src/gtknexus.lisp:1.2 Fri Oct 31 05:52:52 2003 +++ lgtk/src/gtknexus.lisp Wed Nov 5 12:49:56 2003 @@ -28,6 +28,26 @@ (callbacks m)) (call-next-method)))))

+;; It remains to be seen if this works +(defmethod destroy ((m g-objmeta)) + (debugf t "Here we go destroying a g-objmeta~%") + (let ((standing (destroyers m))) + (cond ((and standing (kill-on-gc-p m)) + (debugf t "It is still standing.~%") + (mapcar #'destroy (callbacks m)) + (debugf t "Callbacks deallocated.~%") + (mapcar #'destroy (destroyers m)) + (debugf t "Destroyers removed.~%") + ;; In particular - is this the right function? + (gtk-aliens::|g_object_unref| (contents m)) + (debugf t "Object killed.~%") + (call-next-method)) + (t (mapcar #'(lambda (x) + (setf (retire-p x) nil) + (destroy x)) + (callbacks m)) + (call-next-method))))) + (defmethod destroy ((c gtk-object-cb-meta)) (let* ((retire-p (retire-p c)) (cap (capsule c))