- lgtk-cvs@common-lisp.net - mailman3.common-lisp.net

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 09 Nov '03

09 Nov '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv20234 Modified Files: lgtk.asd Log Message: Fixed another minor typo in lgtk.asd / changed the name of destroy-on-cg-p: it is now destroy real-object. Date: Sun Nov 9 12:32:45 2003 Author: mmommer Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.6 lgtk/lgtk.asd:1.7 --- lgtk/lgtk.asd:1.6 Sun Nov 9 11:34:49 2003 +++ lgtk/lgtk.asd Sun Nov 9 12:32:45 2003 @@ -95,7 +95,7 @@ ((:file "port") (:file "nexus" :depends-on ("port")) (:file "widgets" :depends-on ("nexus")) - (:file "dynaslot" :depends-on ("bindings")) + (:file "dynaslot" :depends-on ("bindings" "nexus")) (:file "enums" :depends-on ("bindings")) (:file "bindings" :depends-on ("port"))

1 0

[lgtk-cvs] CVS update: lgtk/src/gtknexus.lisp lgtk/src/nexus.lisp
by Mario Mommer 09 Nov '03

09 Nov '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv20234/src Modified Files: gtknexus.lisp nexus.lisp Log Message: Fixed another minor typo in lgtk.asd / changed the name of destroy-on-cg-p: it is now destroy real-object. Date: Sun Nov 9 12:32:46 2003 Author: mmommer Index: lgtk/src/gtknexus.lisp diff -u lgtk/src/gtknexus.lisp:1.3 lgtk/src/gtknexus.lisp:1.4 --- lgtk/src/gtknexus.lisp:1.3 Wed Nov 5 12:49:56 2003 +++ lgtk/src/gtknexus.lisp Sun Nov 9 12:32:46 2003 @@ -11,9 +11,10 @@ (defvar *gtkcallbacks* (make-instance 'idnexus)) (defmethod destroy ((m gtk-objmeta)) - (debugf t "Here we go destroying a gtk-objmeta~%") + (debugf t "Here we go destroying a gtk-objmeta. ID: ~X~%" + (metacapsule-identify m)) (let ((standing (destroyers m))) - (cond ((and standing (kill-on-gc-p m)) + (cond ((and standing (destroy-real-object m) (contents m)) (debugf t "It is still standing.~%") (mapcar #'destroy (callbacks m)) (debugf t "Callbacks deallocated.~%") @@ -32,7 +33,7 @@ (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)) + (cond ((and standing (destroy-real-object m)) (debugf t "It is still standing.~%") (mapcar #'destroy (callbacks m)) (debugf t "Callbacks deallocated.~%") Index: lgtk/src/nexus.lisp diff -u lgtk/src/nexus.lisp:1.2 lgtk/src/nexus.lisp:1.3 --- lgtk/src/nexus.lisp:1.2 Fri Oct 31 05:52:53 2003 +++ lgtk/src/nexus.lisp Sun Nov 9 12:32:46 2003 @@ -14,7 +14,7 @@ :contents :metacapsule :metacapsule-identify - :kill-on-gc-p + :destroy-real-object :bag :meta :nexus @@ -78,7 +78,7 @@ :initform nil) ;; Do we destroy this on GC? Good question. On by default. - (kill-on-gc-p :accessor kill-on-gc-p + (destroy-real-object :accessor destroy-real-object :initform T) ;; The nexus keeps a reference to it. Needed for bookkeeping. @@ -225,7 +225,8 @@ (if n (remhash (metacapsule-identify meta) (table n))) - (debugf t "Removed ~a from nexus ~a.~%" meta n))) + (debugf t "Removed ~a from nexus ~a.~%" meta n)) + (setf (destroy-real-object meta) nil)) (defmethod destroy ((meta idmeta)) (let ((id (id meta))) @@ -233,4 +234,5 @@ (remhash (id meta) (table (nexus meta))) (forget-id (id meta)) (setf (id meta) nil)) - (t (debugf t "idmeta redestroyed.~%"))))) + (t (debugf t "idmeta redestroyed.~%")))) + (setf (destroy-real-object meta) nil))

1 0

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 09 Nov '03

09 Nov '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv31588 Modified Files: lgtk.asd Log Message: Now lgtk compiles and loads as it should. Date: Sun Nov 9 11:34:49 2003 Author: mmommer Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.5 lgtk/lgtk.asd:1.6 --- lgtk/lgtk.asd:1.5 Wed Nov 5 16:20:41 2003 +++ lgtk/lgtk.asd Sun Nov 9 11:34:49 2003 @@ -104,7 +104,8 @@ (:file "gtkpackage" :depends-on ("widgets" "nexus" - "enums" "bindings")) + "enums" "bindings" + "dynaslot")) (:file "gtkenums" :depends-on ("gtkpackage" "enums")) (:file "gtkclasshierarchy" :depends-on ("gtkpackage"))

1 0

[lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/gtkpackage.lisp
by Mario Mommer 05 Nov '03

05 Nov '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv10581/src Modified Files: bindings.lisp gtkpackage.lisp Log Message: Added infrastructure for the slot definition stuff Date: Wed Nov 5 16:20:41 2003 Author: mmommer Index: lgtk/src/bindings.lisp diff -u lgtk/src/bindings.lisp:1.2 lgtk/src/bindings.lisp:1.3 --- lgtk/src/bindings.lisp:1.2 Wed Nov 5 12:49:56 2003 +++ lgtk/src/bindings.lisp Wed Nov 5 16:20:41 2003 @@ -9,8 +9,8 @@ (defpackage #:defbinding (:export #:def-binding #:def-bindings-types #:def-raw-binding #:set-aliens-package #:def-binding-type - #:in-filter #:out-filter #:alien-type) - (:use common-lisp clnexus-port)) + #:in-filter #:out-filter #:alien-type #:buildform) + (:use :common-lisp :clnexus-port)) (in-package #:defbinding) Index: lgtk/src/gtkpackage.lisp diff -u lgtk/src/gtkpackage.lisp:1.1.1.1 lgtk/src/gtkpackage.lisp:1.2 --- lgtk/src/gtkpackage.lisp:1.1.1.1 Mon Oct 27 14:15:02 2003 +++ lgtk/src/gtkpackage.lisp Wed Nov 5 16:20:41 2003 @@ -49,4 +49,5 @@ ;; enums. Only export those which can be combined via | in ;; C. See file enums.lisp for details. :gtkattachoptions) - (:use common-lisp nexus widget-nexus callback enums defbinding clnexus-port)) + (:use common-lisp nexus widget-nexus callback enums defbinding clnexus-port + dynaslot))

1 0

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 05 Nov '03

05 Nov '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv10581 Modified Files: lgtk.asd Log Message: Added infrastructure for the slot definition stuff Date: Wed Nov 5 16:20:41 2003 Author: mmommer Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.4 lgtk/lgtk.asd:1.5 --- lgtk/lgtk.asd:1.4 Wed Nov 5 12:49:55 2003 +++ lgtk/lgtk.asd Wed Nov 5 16:20:41 2003 @@ -95,6 +95,7 @@ ((:file "port") (:file "nexus" :depends-on ("port")) (:file "widgets" :depends-on ("nexus")) + (:file "dynaslot" :depends-on ("bindings")) (:file "enums" :depends-on ("bindings")) (:file "bindings" :depends-on ("port"))

1 0

[lgtk-cvs] CVS update: lgtk/examples/dialog.lisp
by Mario Mommer 05 Nov '03

05 Nov '03

Update of /project/lgtk/cvsroot/lgtk/examples In directory common-lisp.net:/tmp/cvs-serv10321 Added Files: dialog.lisp Log Message: A dialog example. Date: Wed Nov 5 16:19:44 2003 Author: mmommer

1 0

[lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp
by Mario Mommer 05 Nov '03

05 Nov '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv9018 Modified Files: gtkbindings.lisp Log Message: Added frame widgets. Added dialogs w. corresponding slots. Date: Wed Nov 5 16:18:19 2003 Author: mmommer Index: lgtk/src/gtkbindings.lisp diff -u lgtk/src/gtkbindings.lisp:1.3 lgtk/src/gtkbindings.lisp:1.4 --- lgtk/src/gtkbindings.lisp:1.3 Wed Nov 5 12:49:56 2003 +++ lgtk/src/gtkbindings.lisp Wed Nov 5 16:18:19 2003 @@ -201,6 +201,10 @@ (c-string tip_text) (c-string tip_private))) +(def-binding "gtk_dialog_new" (gtkdialog)) + +(def-binding "gtk_frame_new" (gtkframe (c-string label))) + (def-binding "gtk_table_new" (gtktable (guint rows) (guint columns) @@ -366,6 +370,21 @@ :after (lambda (x) (gcconnect x range) x)) + +(begin-slot-declarations) + +(add-alien-slots gtkdialog "GtkDialog" + (("window" gtkwindow) + ("vbox" gtkvbox) + ("action_area" gtkhbox))) + + +(generate-alien-accessors + :cflags lgtk-asd::*gtkcflags* + :cc lgtk-asd::*ccompiler* + :headers '("gtk/gtk.h") + :probedir lgtk-asd::*source-dir*) + ;; Raw bindings. These need special care (def-raw-binding "g_signal_connect_data"

1 0

[lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp
by Mario Mommer 05 Nov '03

05 Nov '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv8510 Added Files: dynaslot.lisp Log Message: This makes it possible to access isolated slots in widgets. Date: Wed Nov 5 16:16:51 2003 Author: mmommer

1 0

[lgtk-cvs] CVS update: lgtk/lgtk.asd
by Mario Mommer 05 Nov '03

05 Nov '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv31410 Modified Files: lgtk.asd Log Message: Fixed a few things, and added a bit of gtk functionality. Date: Wed Nov 5 12:49:55 2003 Author: mmommer Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.3 lgtk/lgtk.asd:1.4 --- lgtk/lgtk.asd:1.3 Wed Oct 29 12:59:10 2003 +++ lgtk/lgtk.asd Wed Nov 5 12:49:55 2003 @@ -10,6 +10,8 @@ (in-package :lgtk-asd) +(defvar *ccompiler* "cc") + ;; Split a string at whitespace. (defun splitatspc (str) (labels ((whitespace-p (c) @@ -45,7 +47,20 @@ ;; insenitive. (splitatspc (read-line str)))))))) -(defvar *ccompiler* "cc") +(defun get-gtk-cflags-list () + (let ((prc (ext:run-program "pkg-config" '("--cflags" "gtk+-2.0") + :output :stream))) + (if (not prc) + (error "Could not run #\"pckg-config!") + (let ((str (ext:process-output prc)) + (ecode (ext:process-exit-code prc))) + (if (not (eql ecode 0)) + (error "Could not find gtk+-2.0") + (read-line str)))))) + +(defparameter *gtklibs* (get-gtk-libs-list)) +(defparameter *gtkcflags* (get-gtk-cflags-list)) +(defvar *source-dir* nil) (defclass gtk-libs-handle (c-source-file) ()) @@ -62,8 +77,9 @@ (error 'operation-error :component c :operation o))) (defmethod perform ((o load-op) (c gtk-libs-handle)) - (ext:load-foreign (namestring (car (output-files o c))) - :libraries (get-gtk-libs-list))) + (setf *source-dir* (pathname-directory (component-pathname c))) + (ext:load-foreign (namestring (car (output-files o c))) + :libraries *gtklibs*)) (defsystem lgtk :name "lgtk" @@ -79,7 +95,7 @@ ((:file "port") (:file "nexus" :depends-on ("port")) (:file "widgets" :depends-on ("nexus")) - (:file "enums") + (:file "enums" :depends-on ("bindings")) (:file "bindings" :depends-on ("port"))

1 0

[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
by Mario Mommer 05 Nov '03

05 Nov '03

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))

1 0