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

[lgtk-cvs] CVS update: lgtk/src/gtkbindings.lisp lgtk/src/gtkclasshierarchy.lisp lgtk/src/gtklisp.lisp lgtk/src/gtknexus.lisp lgtk/src/nexus.lisp lgtk/src/widgets.lisp
by Mario Mommer 31 Oct '03

31 Oct '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv20598/src Modified Files: gtkbindings.lisp gtkclasshierarchy.lisp gtklisp.lisp gtknexus.lisp nexus.lisp widgets.lisp Log Message: The identity of accessory objects (like GSlist) gets properly handled. Date: Fri Oct 31 05:52:53 2003 Author: mmommer Index: lgtk/src/gtkbindings.lisp diff -u lgtk/src/gtkbindings.lisp:1.1.1.1 lgtk/src/gtkbindings.lisp:1.2 --- lgtk/src/gtkbindings.lisp:1.1.1.1 Mon Oct 27 14:14:55 2003 +++ lgtk/src/gtkbindings.lisp Fri Oct 31 05:52:52 2003 @@ -17,11 +17,15 @@ (defun rbooltrans (x) (if (/= x 0) t nil)) -(defclass gslist (simple-capsule) ()) +'(defclass gslist (simple-capsule) ()) -(defun gslist-capsule (obj) +'(defun gslist-capsule (obj) (make-instance 'gslist :contents obj)) +(defclass gslist (sapcapsule) ()) + +(def-encapsulator gslist-encap gslist) + ;; For types where nil is acceptable as an object (defun contents-nil (obj) (cond ((null obj) obj) @@ -36,7 +40,7 @@ (gslist :in 'contents-nil - :out 'gslist-capsule + :out 'gslist-encap :alien '(* t)) (gtkwindowtype @@ -149,6 +153,10 @@ (def-binding "gtk_radio_button_new_with_mnemonic_from_widget" (gtkradiobutton (gtkradiobutton group) (c-string msg))) + +(def-binding "gtk_radio_button_get_group" + (gslist (gtkradiobutton obj)) + :after (lambda (x) (gcconnect obj x) x)) (def-binding "gtk_toggle_button_get_active" (gboolean (gtktogglebutton wid))) Index: lgtk/src/gtkclasshierarchy.lisp diff -u lgtk/src/gtkclasshierarchy.lisp:1.1.1.1 lgtk/src/gtkclasshierarchy.lisp:1.2 --- lgtk/src/gtkclasshierarchy.lisp:1.1.1.1 Mon Oct 27 14:15:07 2003 +++ lgtk/src/gtkclasshierarchy.lisp Fri Oct 31 05:52:52 2003 @@ -38,7 +38,6 @@ :initarg :meta :initform (find-class 'gtk-objmeta)))) - ;;; ;;; Here we import the complete gtk class hierarchy. ;;; @@ -170,3 +169,4 @@ ;; engage. (make-gtk-object-hierarchy)) + Index: lgtk/src/gtklisp.lisp diff -u lgtk/src/gtklisp.lisp:1.1.1.1 lgtk/src/gtklisp.lisp:1.2 --- lgtk/src/gtklisp.lisp:1.1.1.1 Mon Oct 27 14:15:00 2003 +++ lgtk/src/gtklisp.lisp Fri Oct 31 05:52:52 2003 @@ -115,14 +115,14 @@ (let ((it (make-instance capsule :contents realw :nexus *gtkobjects*))) - - ;; We need at least one destroy call to know it's over and remove - ;; all activable trace of the widget. - (g-signal-connect it gtkdestroy - #'dummy-func) - it)))))) +;; We need at least one destroy call to know it's over and remove +;; all activable trace of the widget. +(defmethod initialize-instance :after ((it gtk-objcapsule) &key) + (g-signal-connect it + gtkdestroy + #'dummy-func)) ;; Initialize. (eval-when (:load-toplevel :execute :compile-toplevel) Index: lgtk/src/gtknexus.lisp diff -u lgtk/src/gtknexus.lisp:1.1.1.1 lgtk/src/gtknexus.lisp:1.2 --- lgtk/src/gtknexus.lisp:1.1.1.1 Mon Oct 27 14:15:02 2003 +++ lgtk/src/gtknexus.lisp Fri Oct 31 05:52:52 2003 @@ -13,7 +13,7 @@ (defmethod destroy ((m gtk-objmeta)) (debugf t "Here we go destroying a gtk-objmeta~%") (let ((standing (destroyers m))) - (cond (standing + (cond ((and standing (kill-on-gc-p 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.1.1.1 lgtk/src/nexus.lisp:1.2 --- lgtk/src/nexus.lisp:1.1.1.1 Mon Oct 27 14:15:05 2003 +++ lgtk/src/nexus.lisp Fri Oct 31 05:52:53 2003 @@ -14,6 +14,7 @@ :contents :metacapsule :metacapsule-identify + :kill-on-gc-p :bag :meta :nexus @@ -76,6 +77,10 @@ (capsule :initarg :capsule :initform nil) + ;; Do we destroy this on GC? Good question. On by default. + (kill-on-gc-p :accessor kill-on-gc-p + :initform T) + ;; The nexus keeps a reference to it. Needed for bookkeeping. (nexus :accessor nexus :initarg :nexus @@ -214,11 +219,12 @@ (setf (slot-value meta 'id) id) id)))) -;; Standard destroy methods. Like this they would not make any sense. +;; Standard destroy methods. Like this they would not make much sense. (defmethod destroy ((meta metacapsule)) (let ((n (nexus meta))) (if n (remhash (metacapsule-identify meta) (table n))) + (debugf t "Removed ~a from nexus ~a.~%" meta n))) (defmethod destroy ((meta idmeta)) Index: lgtk/src/widgets.lisp diff -u lgtk/src/widgets.lisp:1.1.1.1 lgtk/src/widgets.lisp:1.2 --- lgtk/src/widgets.lisp:1.1.1.1 Mon Oct 27 14:15:08 2003 +++ lgtk/src/widgets.lisp Fri Oct 31 05:52:53 2003 @@ -11,6 +11,8 @@ :widcapsule :callbacks :destroyers + :sapcapsule + :sapmeta :resource :callback-resource :marker @@ -30,6 +32,10 @@ (in-package :widget-nexus) (defclass sapmeta (metacapsule) ()) +(defclass sapcapsule (weak-capsule) + ((meta :accessor meta + :initarg :meta + :initform (find-class 'sapmeta)))) (defmethod metacapsule-identify ((m sapmeta)) (alien-address (contents m)))

1 0

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

29 Oct '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv5080 Modified Files: lgtk.asd Log Message: Fixed lgtk.asd. Now actually works properly. Date: Wed Oct 29 12:59:10 2003 Author: mmommer Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.2 lgtk/lgtk.asd:1.3 --- lgtk/lgtk.asd:1.2 Wed Oct 29 12:43:37 2003 +++ lgtk/lgtk.asd Wed Oct 29 12:59:10 2003 @@ -49,7 +49,7 @@ (defclass gtk-libs-handle (c-source-file) ()) -(defmethod output-flies ((o t) (c c-source-file)) ; bzzzzzzzzz... +(defmethod output-files ((o operation) (c c-source-file)) (list (make-pathname :name (component-name c) :type "o" :defaults (component-pathname c)))) @@ -58,11 +58,11 @@ (unless (zerop (run-shell-command "~A ~A -c -o ~A" *ccompiler* (namestring (component-pathname c)) - (namestring (car (output-flies o c))))) + (namestring (car (output-files o c))))) (error 'operation-error :component c :operation o))) (defmethod perform ((o load-op) (c gtk-libs-handle)) - (ext:load-foreign (namestring (car (output-flies o c))) + (ext:load-foreign (namestring (car (output-files o c))) :libraries (get-gtk-libs-list))) (defsystem lgtk

1 0

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

29 Oct '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv30494 Modified Files: lgtk-examples.asd lgtk.asd Log Message: Each asd has its own package and does not clutter cl-user. Date: Wed Oct 29 12:43:37 2003 Author: mmommer Index: lgtk/lgtk-examples.asd diff -u lgtk/lgtk-examples.asd:1.1.1.1 lgtk/lgtk-examples.asd:1.2 --- lgtk/lgtk-examples.asd:1.1.1.1 Mon Oct 27 14:14:40 2003 +++ lgtk/lgtk-examples.asd Wed Oct 29 12:43:37 2003 @@ -5,6 +5,12 @@ ;; This code comes under the terms of the modified BSD license ("sans ;; advertising clause"). See the file COPYING for details. + +(defpackage #:lgtk-examples-asd + (:use :cl :asdf)) + +(in-package :lgtk-examples-asd) + (defsystem lgtk-examples :components Index: lgtk/lgtk.asd diff -u lgtk/lgtk.asd:1.1.1.1 lgtk/lgtk.asd:1.2 --- lgtk/lgtk.asd:1.1.1.1 Mon Oct 27 14:14:41 2003 +++ lgtk/lgtk.asd Wed Oct 29 12:43:37 2003 @@ -5,6 +5,11 @@ ;; This code comes under the terms of the modified BSD license ("sans ;; advertising clause"). See the file COPYING for details. +(defpackage #:lgtk-asd + (:use :cl :asdf)) + +(in-package :lgtk-asd) + ;; Split a string at whitespace. (defun splitatspc (str) (labels ((whitespace-p (c)

1 0

[lgtk-cvs] CVS update: lgtk/src/port.lisp
by Mario Mommer 29 Oct '03

29 Oct '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv21056/src Modified Files: port.lisp Log Message: Added a detail in the installation procedure. Date: Wed Oct 29 12:20:45 2003 Author: mmommer Index: lgtk/src/port.lisp diff -u lgtk/src/port.lisp:1.2 lgtk/src/port.lisp:1.3 --- lgtk/src/port.lisp:1.2 Wed Oct 29 11:51:16 2003 +++ lgtk/src/port.lisp Wed Oct 29 12:20:45 2003 @@ -57,7 +57,6 @@ (defmacro def-alien-routine (&rest stuff) #+cmu `(alien:def-alien-routine ,@stuff)) - ;;; GC magic #+cmu (defvar *weak-pointer-type* 'ext:weak-pointer)

1 0

[lgtk-cvs] CVS update: lgtk/INSTALL.txt
by Mario Mommer 29 Oct '03

29 Oct '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv21056 Modified Files: INSTALL.txt Log Message: Added a detail in the installation procedure. Date: Wed Oct 29 12:20:44 2003 Author: mmommer Index: lgtk/INSTALL.txt diff -u lgtk/INSTALL.txt:1.1.1.1 lgtk/INSTALL.txt:1.2 --- lgtk/INSTALL.txt:1.1.1.1 Mon Oct 27 14:14:38 2003 +++ lgtk/INSTALL.txt Wed Oct 29 12:20:44 2003 @@ -17,8 +17,9 @@ Installing - If you don't have CMUCL 19a, load the file callback.lisp into a - freshly started lisp image. Now, issue the command + If you don't have CMUCL 19a, load the file callback.x86f (which + you get by compiling the file callback.lisp - this is essential) + into a freshly started lisp image. Now, issue the command (save-lisp "lisp.core")

1 0

[lgtk-cvs] CVS update: lgtk/src/port.lisp
by Mario Mommer 29 Oct '03

29 Oct '03

Update of /project/lgtk/cvsroot/lgtk/src In directory common-lisp.net:/tmp/cvs-serv7476/src Modified Files: port.lisp Log Message: Corrected a small error. Date: Wed Oct 29 11:51:22 2003 Author: mmommer Index: lgtk/src/port.lisp diff -u lgtk/src/port.lisp:1.1.1.1 lgtk/src/port.lisp:1.2 --- lgtk/src/port.lisp:1.1.1.1 Mon Oct 27 14:15:07 2003 +++ lgtk/src/port.lisp Wed Oct 29 11:51:16 2003 @@ -48,7 +48,7 @@ (let ((it (cond ((atom key) (cadr (assoc key *c-types*))) (t (mapcar #'port-alien-type key))))) (if it it - (warn (format nil "~A not is not an alien type"))))) + (warn "~A not is not an alien type" key)))) ;; Get the actual pointer number (defun alien-address (it)

1 0

[lgtk-cvs] CVS update: Module improted: lgtk
by Mario Mommer 27 Oct '03

27 Oct '03

Update of /project/lgtk/cvsroot/lgtk In directory common-lisp.net:/tmp/cvs-serv31113 Log Message: Initial checkin. Status: Vendor Tag: mmommer Release Tags: initial_checkin N lgtk/COPYING N lgtk/INSTALL.txt N lgtk/README.txt N lgtk/lgtk-examples.asd N lgtk/lgtk.asd N lgtk/examples/check-button.lisp N lgtk/examples/cool-button.lisp N lgtk/examples/hello-world.lisp N lgtk/examples/hello-world2.lisp N lgtk/examples/mp-hello-world.lisp N lgtk/examples/packing-boxes.lisp N lgtk/examples/radio-buttons.lisp N lgtk/examples/splash-msg.lisp N lgtk/examples/tables-hw.lisp N lgtk/examples/toggle-button.lisp N lgtk/examples/scale1.lisp N lgtk/src/bindings.lisp N lgtk/src/enums.lisp N lgtk/src/gtkbindings.lisp N lgtk/src/gtkenums.lisp N lgtk/src/gtklisp.lisp N lgtk/src/gtknexus.lisp N lgtk/src/gtkpackage.lisp N lgtk/src/libhandle.c N lgtk/src/nexus.lisp N lgtk/src/gtkclasshierarchy.lisp N lgtk/src/port.lisp N lgtk/src/widgets.lisp No conflicts created by this import Date: Mon Oct 27 14:15:08 2003 Author: mmommer New module lgtk added

1 0