[lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/enums.lisp lgtk/src/gtkbindings.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtkenums.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp
Mario Mommer
mmommer at common-lisp.net
Wed Nov 5 17:49:56 UTC 2003
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))
More information about the Lgtk-cvs
mailing list