From mmommer at common-lisp.net Wed Nov 5 17:49:56 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 12:49:56 -0500 Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd Message-ID: 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")) From mmommer at common-lisp.net Wed Nov 5 17:49:56 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 12:49:56 -0500 Subject: [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 Message-ID: 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)) From mmommer at common-lisp.net Wed Nov 5 21:16:51 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 16:16:51 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp Message-ID: 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 From mmommer at common-lisp.net Wed Nov 5 21:18:19 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 16:18:19 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp Message-ID: 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" From mmommer at common-lisp.net Wed Nov 5 21:19:45 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 16:19:45 -0500 Subject: [lgtk-cvs] CVS update: lgtk/examples/dialog.lisp Message-ID: 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 From mmommer at common-lisp.net Wed Nov 5 21:20:41 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 16:20:41 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/gtkpackage.lisp Message-ID: 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)) From mmommer at common-lisp.net Wed Nov 5 21:20:41 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Wed, 05 Nov 2003 16:20:41 -0500 Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd Message-ID: 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")) From mmommer at common-lisp.net Sun Nov 9 16:34:49 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Sun, 09 Nov 2003 11:34:49 -0500 Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd Message-ID: 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")) From mmommer at common-lisp.net Sun Nov 9 17:32:46 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Sun, 09 Nov 2003 12:32:46 -0500 Subject: [lgtk-cvs] CVS update: lgtk/lgtk.asd Message-ID: 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")) From mmommer at common-lisp.net Sun Nov 9 17:32:46 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Sun, 09 Nov 2003 12:32:46 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/gtknexus.lisp lgtk/src/nexus.lisp Message-ID: 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)) From mmommer at common-lisp.net Mon Nov 10 20:44:48 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Mon, 10 Nov 2003 15:44:48 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/dynaslot.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtklisp.lisp lgtk/src/nexus.lisp Message-ID: Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv24672 Modified Files: bindings.lisp dynaslot.lisp gtkclasshierarchy.lisp gtklisp.lisp nexus.lisp Log Message: This change makes sure that (gtk) objects which are members of other (gtk) objects do not get destroyed explicitly at gc time. Usually, objects destroy their own members. Date: Mon Nov 10 15:44:47 2003 Author: mmommer Index: lgtk/src/bindings.lisp diff -u lgtk/src/bindings.lisp:1.3 lgtk/src/bindings.lisp:1.4 --- lgtk/src/bindings.lisp:1.3 Wed Nov 5 16:20:41 2003 +++ lgtk/src/bindings.lisp Mon Nov 10 15:44:47 2003 @@ -9,7 +9,7 @@ (defpackage #:defbinding (:export #:def-binding #:def-bindings-types #:def-raw-binding #:set-aliens-package #:def-binding-type - #:in-filter #:out-filter #:alien-type #:buildform) + #:in-filter #:out-filter #:alien-type #:buildform #:_2-) (:use :common-lisp :clnexus-port)) (in-package #:defbinding) @@ -46,11 +46,27 @@ (defun alien-type (symbol) (port-alien-type (binding-type-alien (get symbol 'binding-type)))) -(defun in-filter (symbol) - (binding-type-in (get symbol 'binding-type))) - -(defun out-filter (symbol) - (binding-type-out (get symbol 'binding-type))) +(defun in-filter (symbol &rest args) + (let ((bto (binding-type-in (get symbol 'binding-type))) + (x (gensym "out-filter"))) + (if bto + (if args + `(lambda (,x) + (,bto ,x , at args)) + bto) + (if args + (error "filter NIL does not accept parameters (obviously)."))))) + +(defun out-filter (symbol &rest args) + (let ((bto (binding-type-out (get symbol 'binding-type))) + (x (gensym "out-filter"))) + (if bto + (if args + `(lambda (,x) + (,bto ,x , at args)) + bto) + (if args + (error "filter NIL does not accept parameters (obviously)."))))) (defun buildform (func arg) (if func (list func arg) Index: lgtk/src/dynaslot.lisp diff -u lgtk/src/dynaslot.lisp:1.1 lgtk/src/dynaslot.lisp:1.2 --- lgtk/src/dynaslot.lisp:1.1 Wed Nov 5 16:16:51 2003 +++ lgtk/src/dynaslot.lisp Mon Nov 10 15:44:47 2003 @@ -58,7 +58,8 @@ &key (reader t) (writer t) - (export t)) + (export t) + (destroy nil)) req (let ((sname (intern (format nil "~A-~A" oname (map 'string @@ -67,7 +68,7 @@ `( ,(if reader `(defmethod ,sname ((x ,oname)) - ,(buildform (out-filter type) + ,(buildform (out-filter type :destroy destroy) `(peek (contents x) ,offs ,(alien-type type))))) ,(if writer Index: lgtk/src/gtkclasshierarchy.lisp diff -u lgtk/src/gtkclasshierarchy.lisp:1.3 lgtk/src/gtkclasshierarchy.lisp:1.4 --- lgtk/src/gtkclasshierarchy.lisp:1.3 Wed Nov 5 12:49:56 2003 +++ lgtk/src/gtkclasshierarchy.lisp Mon Nov 10 15:44:47 2003 @@ -55,7 +55,8 @@ (contents x))))) (defmacro def-encapsulator (name type) - `(defun ,name (x) (alien-encapsulate x ',type))) + `(defun ,name (x &key (destroy t)) + (alien-encapsulate x ',type :destroy destroy))) (defun gencap (symb) (intern (format nil "~A-ENCAP" symb))) Index: lgtk/src/gtklisp.lisp diff -u lgtk/src/gtklisp.lisp:1.3 lgtk/src/gtklisp.lisp:1.4 --- lgtk/src/gtklisp.lisp:1.3 Wed Nov 5 12:49:56 2003 +++ lgtk/src/gtklisp.lisp Mon Nov 10 15:44:47 2003 @@ -106,7 +106,7 @@ it)))))) -(defun alien-encapsulate (realw capsule) +(defun alien-encapsulate (realw capsule &key (destroy t)) (let ((addrnum (alien-address realw))) (if (zerop addrnum) nil (let ((isit (gethash (alien-address realw) @@ -114,7 +114,8 @@ (if isit (capsule isit) (let ((it (make-instance capsule :contents realw - :nexus *gtkobjects*))) + :nexus *gtkobjects* + :destroy-real-object destroy))) it)))))) ;; We need at least one destroy call to know it's over and remove Index: lgtk/src/nexus.lisp diff -u lgtk/src/nexus.lisp:1.3 lgtk/src/nexus.lisp:1.4 --- lgtk/src/nexus.lisp:1.3 Sun Nov 9 12:32:46 2003 +++ lgtk/src/nexus.lisp Mon Nov 10 15:44:47 2003 @@ -79,7 +79,8 @@ ;; Do we destroy this on GC? Good question. On by default. (destroy-real-object :accessor destroy-real-object - :initform T) + :initarg :destroy-real-object + :initform T) ;; The nexus keeps a reference to it. Needed for bookkeeping. (nexus :accessor nexus @@ -105,12 +106,13 @@ (format t "~S ~S~%" a b)) (defmethod initialize-instance :after ((c capsule) - &key contents nexus) + &key contents nexus destroy-real-object) (setf (meta c) (make-instance (meta c) :contents contents :capsule c - :nexus nexus))) + :nexus nexus + :destroy-real-object destroy-real-object))) ;; Only defined on metas, but the user is king. (defmethod destroy ((c capsule)) From mmommer at common-lisp.net Mon Nov 10 21:44:08 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Mon, 10 Nov 2003 16:44:08 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/dynaslot.lisp Message-ID: Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv19310 Modified Files: dynaslot.lisp Log Message: Slot "a_slot" becomes now a-slot in lisp. Added a :lisp-name option to ADD-ALIEN-SLOTS, to be able to customize this. Date: Mon Nov 10 16:44:07 2003 Author: mmommer Index: lgtk/src/dynaslot.lisp diff -u lgtk/src/dynaslot.lisp:1.2 lgtk/src/dynaslot.lisp:1.3 --- lgtk/src/dynaslot.lisp:1.2 Mon Nov 10 15:44:47 2003 +++ lgtk/src/dynaslot.lisp Mon Nov 10 16:44:07 2003 @@ -59,12 +59,14 @@ (reader t) (writer t) (export t) - (destroy nil)) + (destroy nil) + (lisp-name nil)) req - (let ((sname (intern (format nil "~A-~A" oname - (map 'string - #'char-upcase - name))))) + (let ((sname (if lisp-name lisp-name + (intern (format nil "~A-~A" oname + (map 'string + #'char-upcase + (_2- name))))))) `( ,(if reader `(defmethod ,sname ((x ,oname)) From mmommer at common-lisp.net Mon Nov 10 21:45:24 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Mon, 10 Nov 2003 16:45:24 -0500 Subject: [lgtk-cvs] CVS update: lgtk/examples/dialog.lisp Message-ID: Update of /project/lgtk/cvsroot/lgtk/examples In directory common-lisp.net:/tmp/cvs-serv20662 Modified Files: dialog.lisp Log Message: The dialog example is now complete. Date: Mon Nov 10 16:45:24 2003 Author: mmommer Index: lgtk/examples/dialog.lisp diff -u lgtk/examples/dialog.lisp:1.1 lgtk/examples/dialog.lisp:1.2 --- lgtk/examples/dialog.lisp:1.1 Wed Nov 5 16:19:42 2003 +++ lgtk/examples/dialog.lisp Mon Nov 10 16:45:23 2003 @@ -3,35 +3,39 @@ (use-package :gtk) (defun dialog () - (let ((dialog (gtk-dialog-new)) - (button1 (gtk-button-new-with-label "Ok...")) - (button2 (gtk-button-new-with-label "Well...")) - (button3 (gtk-button-new-with-label "Ehm...")) - (frame (gtk-frame-new "I want your opinion:")) - (label (gtk-label-new "Aren't dialogs cool?"))) - - (gtk-box-pack-start - (gtkdialog-action_area dialog) - button1) - - (gtk-box-pack-start - (gtkdialog-action_area dialog) - button2) - - (gtk-box-pack-start - (gtkdialog-action_area dialog) - button3) - - (gtk-box-pack-start - (gtkdialog-vbox dialog) - frame) - - (gtk-container-add - frame label) + (labels ((its-over (&rest args) (declare (ignore args)) + (gtk-main-quit))) + (let ((dialog (gtk-dialog-new)) + (frame (gtk-frame-new "I want your opinion:")) + (label (gtk-label-new "Aren't dialogs cool?")) + (button1 (gtk-button-new-with-label "Ok...")) + (button2 (gtk-button-new-with-label "Well...")) + (button3 (gtk-button-new-with-label "Ehm..."))) + + (gtk-box-pack-start + (gtkdialog-action-area dialog) + button1) + + (gtk-box-pack-start + (gtkdialog-action-area dialog) + button2) + + (gtk-box-pack-start + (gtkdialog-action-area dialog) + button3) + + (gtk-box-pack-start + (gtkdialog-vbox dialog) + frame) + + (gtk-container-add + frame label) - (gtk-container-set-border-width frame 10) - (gtk-widget-set-size-request label 30 30) + (gtk-container-set-border-width frame 10) + (gtk-widget-set-size-request label 30 30) - (gtk-widget-show-all dialog) + (g-signal-connect dialog gtkdestroy #'its-over) - (gtk-main))) \ No newline at end of file + (gtk-widget-show-all dialog) + + (gtk-main)))) \ No newline at end of file From mmommer at common-lisp.net Mon Nov 10 21:47:35 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Mon, 10 Nov 2003 16:47:35 -0500 Subject: [lgtk-cvs] CVS update: lgtk/lgtk-examples.asd Message-ID: Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv21561 Modified Files: lgtk-examples.asd Log Message: Added the dialog example. Date: Mon Nov 10 16:47:34 2003 Author: mmommer Index: lgtk/lgtk-examples.asd diff -u lgtk/lgtk-examples.asd:1.2 lgtk/lgtk-examples.asd:1.3 --- lgtk/lgtk-examples.asd:1.2 Wed Oct 29 12:43:37 2003 +++ lgtk/lgtk-examples.asd Mon Nov 10 16:47:34 2003 @@ -24,7 +24,8 @@ (:file "check-button") (:file "radio-buttons") (:file "toggle-button") - (:file "tables-hw")))) + (:file "tables-hw") + (:file "dialog")))) :depends-on (:lgtk)) From mmommer at common-lisp.net Tue Nov 11 21:41:54 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Tue, 11 Nov 2003 16:41:54 -0500 Subject: [lgtk-cvs] CVS update: lgtk/examples/entry.lisp Message-ID: Update of /project/lgtk/cvsroot/lgtk/examples In directory common-lisp.net:/tmp/cvs-serv30646/examples Added Files: entry.lisp Log Message: Added text entries. Also added an example. Date: Tue Nov 11 16:41:54 2003 Author: mmommer From mmommer at common-lisp.net Tue Nov 11 21:41:53 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Tue, 11 Nov 2003 16:41:53 -0500 Subject: [lgtk-cvs] CVS update: lgtk/lgtk-examples.asd Message-ID: Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv30646 Modified Files: lgtk-examples.asd Log Message: Added text entries. Also added an example. Date: Tue Nov 11 16:41:52 2003 Author: mmommer Index: lgtk/lgtk-examples.asd diff -u lgtk/lgtk-examples.asd:1.3 lgtk/lgtk-examples.asd:1.4 --- lgtk/lgtk-examples.asd:1.3 Mon Nov 10 16:47:34 2003 +++ lgtk/lgtk-examples.asd Tue Nov 11 16:41:51 2003 @@ -25,7 +25,8 @@ (:file "radio-buttons") (:file "toggle-button") (:file "tables-hw") - (:file "dialog")))) + (:file "dialog") + (:file "entry")))) :depends-on (:lgtk)) From mmommer at common-lisp.net Tue Nov 11 21:41:54 2003 From: mmommer at common-lisp.net (Mario Mommer) Date: Tue, 11 Nov 2003 16:41:54 -0500 Subject: [lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp Message-ID: Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv30646/src Modified Files: gtkbindings.lisp Log Message: Added text entries. Also added an example. Date: Tue Nov 11 16:41:54 2003 Author: mmommer Index: lgtk/src/gtkbindings.lisp diff -u lgtk/src/gtkbindings.lisp:1.4 lgtk/src/gtkbindings.lisp:1.5 --- lgtk/src/gtkbindings.lisp:1.4 Wed Nov 5 16:18:19 2003 +++ lgtk/src/gtkbindings.lisp Tue Nov 11 16:41:54 2003 @@ -183,9 +183,27 @@ (void (gtktogglebutton wid) (gboolean active))) +(def-binding "gtk_entry_new" + (gtkentry)) + +(def-binding "gtk_entry_set_text" + (void (GtkEntry entry) + (c-string text))) + +(def-binding "gtk_entry_get_text" + (c-string (GtkEntry entry))) + +(def-binding "gtk_editable_set_editable" + (void (GtkEntry entry) + (gboolean active))) + +(def-binding "gtk_entry_set_visibility" + (void (GtkEntry entry) + (gboolean visible))) + (def-binding "gtk_arrow_new" - (GtkWidget (GtkArrowType arrow_type) - (GtkShadowType shadow_type))) + (gtkarrow (GtkArrowType arrow_type) + (GtkShadowType shadow_type))) (def-binding "gtk_arrow_set" (void (GtkArrow arrow)