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

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

11 Nov '03

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

1 0

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

11 Nov '03

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)

1 0

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

11 Nov '03

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

1 0

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

10 Nov '03

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

1 0

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

10 Nov '03

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

1 0

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

10 Nov '03

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

1 0

[lgtk-cvs] CVS update: lgtk/src/bindings.lisp lgtk/src/dynaslot.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtklisp.lisp lgtk/src/nexus.lisp
by Mario Mommer 10 Nov '03

10 Nov '03

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

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