cells-cvs January 2008

cells-cvs@common-lisp.net

2 participants
40 discussions

[cells-cvs] CVS cells-gtk
by ktilton 31 Jan '08

31 Jan '08

Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv1150 Modified Files: menus.lisp textview.lisp Log Message: de-closify the menu used to implement submenus --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/31 03:31:12 1.3 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/31 06:50:25 1.4 @@ -185,7 +185,6 @@ :padding 0) - (def-widget menu-bar (menu-shell) () () ()) @@ -203,35 +202,24 @@ (mk-accel-label :text (label self)))))) (accel :accessor accel :initarg :accel :initform (c-in nil)) (owner :initarg :owner :accessor owner :initform (c-in nil)) - (submenu :initarg :submenu :cell nil :accessor submenu :initform nil) ; gtk-menu-item-get-submenu not doing it. POD - (appended? :initarg :appended? :cell nil :accessor appended? :initform nil)) + (submenu-id :initarg :submenu-id :cell nil :accessor submenu-id :initform nil) ; gtk-menu-item-get-submenu not doing it. POD + ) (right-justified) (activate)) (defobserver .kids ((self menu-shell)) (when new-value (dolist (kid new-value) - - (if (appended? kid) - (break "ducking duplicate append of kid ~a to (~a ~a) already in ~a" kid (id self) self (appended? kid)) - (progn - (trc nil "mshell" (id self) self :kid kid :kidid (id kid) :kidpar (fm-parent kid)) - (gtk-menu-shell-append (id self) (id kid)) - (setf (appended? kid) (cons (id self) self)))))) + (gtk-menu-shell-append (id self) (id kid)))) #+clisp (call-next-method)) (defobserver .kids ((self menu-item)) (when old-value ; pod never occurs ? - (gtk-menu-item-remove-submenu (id self))) + (gtk-menu-item-remove-submenu (id self))) ;; almost certainly wrong -- better to Just Break here? (when new-value - #+chill (when (eq (md-name self) 'test-gtk::SUBMENU-MENUITEM) - (break "NN obs kids enqueues submenu ~a" self cells::*data-pulse-id*)) - (with-integrity (:awaken 'set-sub-menu-actually) - (let ((subid (id (setf (submenu self) - (make-instance 'menu - :md-name (gensym "SUBMENU-MENU") - :kids new-value))))) ;; <=== was mak - (gtk-menu-item-set-submenu (id self) subid))))) + (gtk-menu-item-set-submenu (id self) (setf (submenu-id self) (gtk-menu-new))) + (dolist (kid new-value) + (gtk-menu-shell-append (submenu-id self) (id kid))))) (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel --- /project/cells/cvsroot/cells-gtk/textview.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/textview.lisp 2008/01/31 06:50:25 1.2 @@ -94,8 +94,6 @@ item))) #'(lambda (popup-menu) (loop for old in (old-popups text-view) do - (when-bind (sub (submenu old)) - (gtk-object-forget (id sub) sub)) (gtk-object-forget (id old) old)) (let ((tops (mapcar #'do-padds p-adds))) (setf (old-popups text-view) accum)

1 0

[cells-cvs] CVS cells-gtk/test-gtk
by ktilton 31 Jan '08

31 Jan '08

Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv20829/test-gtk Modified Files: test-gtk.lisp test-menus.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 21:13:44 1.3 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/31 03:31:13 1.4 @@ -39,16 +39,16 @@ :splash-screen-image (namestring *splash-image*) :width 650 :height 550 :kids (c? (the-kids - (let ((tabs '(;"Buttons" - ;"Display" - ;"Layout" + (let ((tabs '("Buttons" + "Display" + "Layout" "Menus" - ;"Textview" - ;"Dialogs" - ;"Addon" - ;"Entry" - ;"Tree-view" + "Textview" + "Dialogs" + "Addon" + "Entry" + "Tree-view" ))) (list (mk-notebook :tab-labels tabs --- /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/30 21:13:44 1.2 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/31 03:31:13 1.3 @@ -17,19 +17,19 @@ :on-activate (callback (widget event data) (trc "TST SAVE") (force-output))) (mk-menu-item - :md-name (gensym "SUBMENU-MENUITEM") + :md-name 'SUBMENU-MENUITEM :label "Submenu" - :kids (kids-list? - (mk-menu-item - :md-name (gensym "SUBITEM-1") - :label "subitem1" - :on-activate (callback (widget event data) - (trc "dribble SAVE") (dribble))) - (mk-menu-item - :md-name (gensym "SUBITEM-2") + :kids (c? (the-kids + (mk-menu-item + :md-name (gensym "SUBITEM-1") + :label "subitem1" + :on-activate (callback (widget event data) + (trc "dribble SAVE") (dribble))) + (mk-menu-item + :md-name (gensym "SUBITEM-2") :label "subitem2") - (mk-menu-item :label "subitem3") - )) + (mk-menu-item :label "subitem3") + ))) (mk-image-menu-item :stock :harddisk :on-activate (callback (widget event data)

1 0

[cells-cvs] CVS cells-gtk
by ktilton 31 Jan '08

31 Jan '08

Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv20829 Modified Files: gtk-app.lisp menus.lisp Log Message: --- /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/30 21:13:44 1.2 +++ /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/31 03:31:12 1.3 @@ -62,7 +62,6 @@ (defvar *gtk-initialized* nil) - (defun start-app (app-name &key debug) (let ((*gtk-debug* debug)) (when (not *gtk-initialized*) @@ -93,8 +92,6 @@ (setf (visible app) t) (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) (unwind-protect - (gtk-main) - #+chill (loop (restart-case (handler-bind @@ -116,13 +113,10 @@ (give-up-cleanly () (return-from start-app)) (report-error-and-give-up (c) (error c)))) ;; clean-up forms (takes down application). - (trcx not-to-be-app 42) + (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? - (trcx gtk-main-quits 42) (loop for i from 0 to 30 do (gtk-main-quit)) - (trcx mopping-events 42) (loop while (gtk-events-pending) do - (trcx gtk-main-iter-do 42) (gtk-main-iteration-do nil))))))) ;;; Restarts --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/30 21:13:44 1.2 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/31 03:31:12 1.3 @@ -224,13 +224,14 @@ (when old-value ; pod never occurs ? (gtk-menu-item-remove-submenu (id self))) (when new-value - (with-integrity (:change 'set-sub-menu-actually) - (unless (submenu self) - (let ((subid (id (setf (submenu self) - (make-instance 'menu - :md-name (gensym "SUBMENU-MENU") - :kids new-value))))) ;; <=== was mak - (gtk-menu-item-set-submenu (id self) subid)))))) + #+chill (when (eq (md-name self) 'test-gtk::SUBMENU-MENUITEM) + (break "NN obs kids enqueues submenu ~a" self cells::*data-pulse-id*)) + (with-integrity (:awaken 'set-sub-menu-actually) + (let ((subid (id (setf (submenu self) + (make-instance 'menu + :md-name (gensym "SUBMENU-MENU") + :kids new-value))))) ;; <=== was mak + (gtk-menu-item-set-submenu (id self) subid))))) (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel

1 0

[cells-cvs] CVS cells
by ktilton 31 Jan '08

31 Jan '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv20671 Modified Files: cell-types.lisp initialize.lisp md-slot-value.lisp model-object.lisp propagate.lisp Log Message: Fixed a whole in initialization such that a slot could be observed twice, unhealthy when observers have side effects. --- /project/cells/cvsroot/cells/cell-types.lisp 2008/01/29 04:29:52 1.28 +++ /project/cells/cvsroot/cells/cell-types.lisp 2008/01/31 03:30:17 1.29 @@ -37,6 +37,7 @@ ; a dependency on the existence of instance owning X (pulse 0 :type fixnum) (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP + (pulse-observed 0 :type fixnum) lazy (optimize t) debug --- /project/cells/cvsroot/cells/initialize.lisp 2006/06/23 01:04:56 1.8 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/01/31 03:30:17 1.9 @@ -32,8 +32,11 @@ ; ; nothing to calculate, but every cellular slot should be output ; - (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) - (ephemeral-reset c)) + (trc nil "awaken cell observing" c) + (when (> *data-pulse-id* (c-pulse-observed c)) + (setf (c-pulse-observed c) *data-pulse-id*) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) + (ephemeral-reset c))) (defmethod awaken-cell ((c c-ruled)) (let (*call-stack*) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/29 04:29:52 1.37 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/31 03:30:17 1.38 @@ -328,7 +328,7 @@ ) ;; (when (trcp c) (break "go optimizing ~a" c)) - #+shh (when (trcp c) + (when (trcp c) (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c)))) ) --- /project/cells/cvsroot/cells/model-object.lisp 2008/01/29 04:29:52 1.17 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/01/31 03:30:17 1.18 @@ -104,7 +104,8 @@ (defmethod md-awaken :around ((self model-object)) (when (eql :nascent (md-state self)) - (call-next-method))) + (call-next-method)) + self) #+test (md-slot-cell-type 'cgtk::label 'cgtk::container) @@ -150,7 +151,12 @@ ;; but first I worried about it being slow keeping the flushed list /and/ searching, then ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)) + (let ((flushed (md-slot-cell-flushed self slot-name))) + (when (or (null flushed) ;; constant, ie, never any cell provided for this slot + (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely + (when flushed + (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))) ((find (c-lazy c) '(:until-asked :always t)) @@ -179,6 +185,11 @@ (cdr (assoc slot-name (cells self))) (get slot-name 'cell))) +(defmethod md-slot-cell-flushed (self slot-name) + (if self + (cdr (assoc slot-name (cells-flushed self))) + (get slot-name 'cell))) + #+test (get 'cgtk::label :cell-types) --- /project/cells/cvsroot/cells/propagate.lisp 2007/11/30 16:51:18 1.28 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/01/31 03:30:17 1.29 @@ -113,8 +113,14 @@ (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c)) - (slot-value-observe (c-slot-name c) (c-model c) - (c-value c) prior-value prior-value-supplied) + (trc nil "c-propagate observing" c) + + ; this next assertion is just to see if we can ever come this way twice. If so, just + ; make it a condition on whether to observe + (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c)) + (setf (c-pulse-observed c) *data-pulse-id*) + (slot-value-observe (c-slot-name c) (c-model c) + (c-value c) prior-value prior-value-supplied)) ;

1 0

[cells-cvs] CVS cells-gtk/test-gtk
by ktilton 30 Jan '08

30 Jan '08

Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv5749/test-gtk Modified Files: test-buttons.lisp test-dialogs.lisp test-gtk.lisp test-menus.lisp Log Message: fixed submenus --- /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-buttons.lisp 2008/01/30 21:13:44 1.2 @@ -26,6 +26,7 @@ (incf (nclics (upper self test-buttons))))) (mk-button :label "Continuable error" :on-clicked (callback (widget event data) + (trc "issuing continuable error" widget event) (error 'gtk-continuable-error :text "Oops!"))) (mk-toggle-button :md-name :toggled-button :markup (c? (with-markup (:foreground (if (value self) :red :blue)) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/30 14:21:02 1.2 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/30 21:13:44 1.3 @@ -28,6 +28,7 @@ :kids (kids-list? (mk-hbox :kids (kids-list? + (append #-libcellsgtk nil #+libcellsgtk @@ -36,19 +37,20 @@ :on-clicked (callback (w e d) (with-integrity (:change 'q4text) - (let ((dialog - (to-be (mk-message-dialog - :md-name :rule-name-dialog - :message "Type something:" - :title "My Title" - :message-type :question - :buttons-type :ok-cancel - :content-area (mk-entry :auto-aupdate t))))) - (print 'back) - (print (list 'value-dialog (value dialog))) - (setf (text (fm^ :message-response)) (value dialog))))))) + (let ((dialog + (to-be (mk-message-dialog + :md-name :rule-name-dialog + :message "Type something:" + :title "My Title" + :message-type :question + :buttons-type :ok-cancel + :content-area (mk-entry :auto-aupdate t))))) + (print 'back) + (print (list 'value-dialog (value dialog))) + (setf (text (fm^ :message-response)) (value dialog))))))) (loop for message-type in '(:info :warning :question :error) collect (make-kid 'test-message :message-type message-type))))) + (mk-label :md-name :message-response) (mk-hbox :kids (kids-list? @@ -62,12 +64,12 @@ :tab-labels (list "Open" "Save" "Select folder" "Create folder") :kids (kids-list? (loop for action in '(:open :save :select-folder :create-folder) collect - (mk-vbox - :kids (kids-list? - (mk-file-chooser-widget :md-name action - :action action - :expand t :fill t - :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) - :select-multiple (c? (value (fm^ :multiple)))) - (mk-check-button :label "Select multiple" :md-name :multiple) - (mk-label :text (c? (format nil "~a ~a" (md-name (psib (psib))) (value (psib (psib)))))))))))))) + (mk-vbox + :kids (kids-list? + (mk-file-chooser-widget :md-name action + :action action + :expand t :fill t + :filters '(("All" "*") ("Text" "*.txt" "*.doc") ("Libraries" "*.so" "*.lib")) + :select-multiple (c? (value (fm^ :multiple)))) + (mk-check-button :label "Select multiple" :md-name :multiple) + (mk-label :text (c? (format nil "~a ~a" (md-name (psib (psib))) (value (psib (psib)))))))))))))) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 14:21:02 1.2 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 21:13:44 1.3 @@ -39,15 +39,16 @@ :splash-screen-image (namestring *splash-image*) :width 650 :height 550 :kids (c? (the-kids - (let ((tabs '("Buttons" - "Display" - "Layout" + (let ((tabs '(;"Buttons" + ;"Display" + ;"Layout" + "Menus" - "Textview" - "Dialogs" - "Addon" - "Entry" - "Tree-view" + ;"Textview" + ;"Dialogs" + ;"Addon" + ;"Entry" + ;"Tree-view" ))) (list (mk-notebook :tab-labels tabs @@ -65,7 +66,10 @@ (defun gtk-demo (&optional dbg) - #-iamnotkenny (ukt:test-prep) + #-iamnotkenny + (PROGN + (dribble "/cells-gtk/demo.log") + (ukt:test-prep)) (cells-gtk-init) (cells-gtk:start-app 'test-gtk::test-gtk :debug dbg)) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-menus.lisp 2008/01/30 21:13:44 1.2 @@ -7,6 +7,7 @@ (mk-menu-bar :kids (kids-list? (mk-menu-item + :md-name 'menu-1 :label "Menu 1" :kids (kids-list? (mk-image-menu-item @@ -14,28 +15,41 @@ :accel '(#\s :control :shift :alt) :image (mk-image :stock :save :icon-size :menu) :on-activate (callback (widget event data) - (trc nil "TST") (force-output))) + (trc "TST SAVE") (force-output))) (mk-menu-item + :md-name (gensym "SUBMENU-MENUITEM") :label "Submenu" :kids (kids-list? - (mk-menu-item :label "subitem1") - (mk-menu-item :label "subitem2") - (mk-menu-item :label "subitem3"))) + (mk-menu-item + :md-name (gensym "SUBITEM-1") + :label "subitem1" + :on-activate (callback (widget event data) + (trc "dribble SAVE") (dribble))) + (mk-menu-item + :md-name (gensym "SUBITEM-2") + :label "subitem2") + (mk-menu-item :label "subitem3") + )) (mk-image-menu-item :stock :harddisk :on-activate (callback (widget event data) - (trc nil "HARDDISK") (force-output))) + (trc "HARDDISK" widget event data) + (force-output))) (mk-image-menu-item :image (mk-image :stock :dialog-info :icon-size :menu) :label-widget (mk-label :markup (with-markup (:foreground :blue) "Blue label"))) (mk-image-menu-item :stock :my-g - :label "user stock icon"))) + :label "user stock icon") + )) (mk-menu-item + :md-name 'menu-2 :label "Menu 2" :visible (c? (value (fm^ :menu2-visible))) - :sensitive (c? (value (fm^ :menu2-sensitive))) + :sensitive (c? (let ((x (fm^ :menu2-sensitive))) + (trc "located m2sensi" x) + (value x))) :kids (kids-list? (mk-tearoff-menu-item) (mk-check-menu-item @@ -47,7 +61,8 @@ (mk-check-menu-item :label "Sub-option 2" :md-name :sub-option2 - :init t))) + :init t)) + ) (mk-menu-item :label "Menu 3" :md-name :menu3 @@ -144,7 +159,7 @@ '("DD/MM/YY" "DD/MM/YYYY" "MM/DD/YY" "YYYY-MM-DD" "YYYY-MM-DDTHH:MM:SS" "DD/MM/YY HH:MM:SS"))))))) (mk-hseparator :padding 5) - (mk-hbox + (mk-hbox :kids (kids-list? (mk-event-box :popup (mk-menu

1 0

[cells-cvs] CVS cells-gtk
by ktilton 30 Jan '08

30 Jan '08

Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv5749 Modified Files: dialogs.lisp gtk-app.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: fixed submenus --- /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 14:21:01 1.2 +++ /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 21:13:44 1.3 @@ -23,27 +23,27 @@ ((message :accessor message :initarg :message :initform nil) (message-type :accessor message-type :initarg :message-type :initform :info) (buttons-type :accessor buttons-type :initarg :buttons-type :initform (c? (if (eql (message-type self) :question) - :yes-no - :close))) + :yes-no + :close))) (content-area :owning t :accessor content-area :initarg :content-area :initform nil)) (markup) () :position :mouse :new-args (c_1 (list +c-null+ - 2 - (ecase (message-type self) - (:info 0) - (:warning 1) - (:question 2) - (:error 3)) - (ecase (buttons-type self) - (:none 0) - (:ok 1) - (:close 2) - (:cancel 3) - (:yes-no 4) - (:ok-cancel 5)) - (message self)))) + 2 + (ecase (message-type self) + (:info 0) + (:warning 1) + (:question 2) + (:error 3)) + (ecase (buttons-type self) + (:none 0) + (:ok 1) + (:close 2) + (:cancel 3) + (:yes-no 4) + (:ok-cancel 5)) + (message self)))) (defmethod md-awaken :after ((self message-dialog)) (print 'md-awaken-after) @@ -55,6 +55,7 @@ (-7 :close) (-8 :yes) (-9 :no)))) + (with-slots (content-area) self (when content-area (setf (value self) (value content-area)) @@ -146,6 +147,8 @@ (if (select-multiple self) (setf (value self) (gtk-file-chooser-get-filenames-strs (id self))) (setf (value self) (gtk-file-chooser-get-filename (id self))))) + (trc "destroying file-chooser-dialog" (id self) self) + (break "ok?") (gtk-widget-destroy (id self)) (gtk-object-forget (id self) self))) --- /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/30 21:13:44 1.2 @@ -83,39 +83,47 @@ (to-be splash) (setf (visible splash) t) (loop while (gtk-events-pending) do - (gtk-main-iteration))) - + (gtk-main-iteration))) + (to-be app) - + (when splash (not-to-be splash) (gtk-window-set-auto-startup-notification t)) (setf (visible app) t) (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) - (unwind-protect - (loop - (restart-case - (handler-bind - ((gtk-user-signals-quit #'give-up-cleanly) - (gtk-continuable-error #'continue-from-error) - (error #'report-error-and-give-up)) - #-lispworks - (gtk-main) - #+lispworks ; give slime a chance. - (loop ; just running your app in a process is not enough. - (loop while (gtk-events-pending) do - (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting"))) - ;; Restart cases - (continue-from-error (c) - (show-message (format nil "Cells-GTK Error: ~a" (text c)) - :message-type :error :title "Cells-GTK Error")) - (give-up-cleanly () (return-from start-app)) - (report-error-and-give-up (c) (error c)))) - ;; clean-up forms (takes down application). - (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? - (loop for i from 0 to 30 do (gtk-main-quit)) - (loop while (gtk-events-pending) do (gtk-main-iteration-do nil))))))) + (unwind-protect + (gtk-main) + #+chill + (loop + (restart-case + (handler-bind + ((gtk-user-signals-quit #'give-up-cleanly) + (gtk-continuable-error #'continue-from-error) + (error #'report-error-and-give-up)) + #-lispworks + (gtk-main) + #+lispworks ; give slime a chance. + (loop ; just running your app in a process is not enough. + (loop while (gtk-events-pending) do + (gtk-main-iteration-do nil)) + (process-wait-with-timeout .01 "GTK event loop waiting"))) + ;; Restart cases + (continue-from-error (c) + (format t "~&Cells-GTK Error: ~a" (text c)) + (show-message (format nil "Cells-GTK Error: ~a" (text c)) + :message-type :error :title "Cells-GTK Error")) + (give-up-cleanly () (return-from start-app)) + (report-error-and-give-up (c) (error c)))) + ;; clean-up forms (takes down application). + (trcx not-to-be-app 42) + (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? + (trcx gtk-main-quits 42) + (loop for i from 0 to 30 do (gtk-main-quit)) + (trcx mopping-events 42) + (loop while (gtk-events-pending) do + (trcx gtk-main-iter-do 42) + (gtk-main-iteration-do nil))))))) ;;; Restarts (defun continue-from-error (c) --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/30 21:13:44 1.2 @@ -184,11 +184,7 @@ () () () :padding 0) -(defobserver .kids ((self menu-shell)) - (when new-value - (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid)))) - #+clisp (call-next-method)) + (def-widget menu-bar (menu-shell) () () ()) @@ -207,10 +203,35 @@ (mk-accel-label :text (label self)))))) (accel :accessor accel :initarg :accel :initform (c-in nil)) (owner :initarg :owner :accessor owner :initform (c-in nil)) - (submenu :cell nil :accessor submenu :initform nil)) ; gtk-menu-item-get-submenu not doing it. POD + (submenu :initarg :submenu :cell nil :accessor submenu :initform nil) ; gtk-menu-item-get-submenu not doing it. POD + (appended? :initarg :appended? :cell nil :accessor appended? :initform nil)) (right-justified) (activate)) +(defobserver .kids ((self menu-shell)) + (when new-value + (dolist (kid new-value) + + (if (appended? kid) + (break "ducking duplicate append of kid ~a to (~a ~a) already in ~a" kid (id self) self (appended? kid)) + (progn + (trc nil "mshell" (id self) self :kid kid :kidid (id kid) :kidpar (fm-parent kid)) + (gtk-menu-shell-append (id self) (id kid)) + (setf (appended? kid) (cons (id self) self)))))) + #+clisp (call-next-method)) + +(defobserver .kids ((self menu-item)) + (when old-value ; pod never occurs ? + (gtk-menu-item-remove-submenu (id self))) + (when new-value + (with-integrity (:change 'set-sub-menu-actually) + (unless (submenu self) + (let ((subid (id (setf (submenu self) + (make-instance 'menu + :md-name (gensym "SUBMENU-MENU") + :kids new-value))))) ;; <=== was mak + (gtk-menu-item-set-submenu (id self) subid)))))) + (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel (let ((mods 0)) @@ -237,13 +258,10 @@ (gtk-accel-label-set-accel-widget (id new-value) (id self)) (gtk-container-add (id self) (id new-value)))) -(defobserver .kids ((self menu-item)) - (when old-value ; pod never occurs ? - (gtk-menu-item-remove-submenu (id self))) - (when new-value - (with-integrity (:change 'set-sub-menu-actually) - (gtk-menu-item-set-submenu (id self) - (id (setf (submenu self) (make-be 'menu :kids new-value))))))) + + +;;;if the make-be is a make-instance we do not crash, but we get an empty submenu (or +;;;is it just disabled?). (def-widget check-menu-item (menu-item) ((init :accessor init :initarg :init :initform nil)) --- /project/cells/cvsroot/cells-gtk/tree-view.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/tree-view.lisp 2008/01/30 21:13:44 1.2 @@ -35,7 +35,7 @@ () :new-args (c_1 (list (item-types self)))) -(defun fail (&rest args) (declare (ignore args))) +(defun tv-fail (&rest args) (declare (ignore args))) (def-widget tree-view () ((columns-def :accessor columns-def :initarg :columns :initform nil) @@ -52,7 +52,7 @@ :container self col-init)) (column-inits self)))) - (select-if :unchanged-if #'fail + (select-if :unchanged-if #'tv-fail :accessor select-if :initarg :select-if :initform (c-in nil)) (roots :accessor roots :initarg :roots :initform nil) (print-fn :accessor print-fn :initarg :print-fn :initform #'identity) --- /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 14:21:01 1.2 +++ /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 21:13:44 1.3 @@ -310,7 +310,8 @@ (defmethod not-to-be :after ((self widget)) (when t ; *gtk-debug* - (trc "WIDGET DESTROY" (md-name self) self) (force-output)) + (trc nil "WIDGET DESTROY" (md-name self) (type-of self) self) + (force-output)) (gtk-object-forget (slot-value self 'id) self) (gtk-widget-destroy (slot-value self 'id)))

1 0

[cells-cvs] CVS cells/utils-kt
by phildebrandt 30 Jan '08

30 Jan '08

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv9106/utils-kt Modified Files: core.lisp Log Message: finally fixed export! for sbcl --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/29 23:30:06 1.4 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/30 14:33:49 1.5 @@ -21,9 +21,11 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) -(defmacro export! (&rest symbols) - `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) - (export ',symbols))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro export! (&rest symbols) + `(eval-when ( :compile-toplevel :load-toplevel :execute) + #+sbssscl (export (list ,@(mapcar #'(lambda (x) (list 'quote x)) symbols))) + #-sbclss (export ',symbols)))) (defmacro define-constant (name value &optional docstring) "Define a constant properly. If NAME is unbound, DEFCONSTANT

1 0

[cells-cvs] CVS cells-gtk/test-gtk
by phildebrandt 30 Jan '08

30 Jan '08

Update of /project/cells/cvsroot/cells-gtk/test-gtk In directory clnet:/tmp/cvs-serv6810/test-gtk Modified Files: test-dialogs.lisp test-gtk.lisp Log Message: merging in ken's and peter's changes from Jan 29th --- /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-dialogs.lisp 2008/01/30 14:21:02 1.2 @@ -35,16 +35,18 @@ (mk-button :label "Query for text" :on-clicked (callback (w e d) - (let ((dialog - (to-be - (mk-message-dialog - :md-name :rule-name-dialog - :message "Type something:" - :title "My Title" - :message-type :question - :buttons-type :ok-cancel - :content-area (mk-entry :auto-aupdate t))))) - (setf (text (fm^ :message-response)) (value dialog)))))) + (with-integrity (:change 'q4text) + (let ((dialog + (to-be (mk-message-dialog + :md-name :rule-name-dialog + :message "Type something:" + :title "My Title" + :message-type :question + :buttons-type :ok-cancel + :content-area (mk-entry :auto-aupdate t))))) + (print 'back) + (print (list 'value-dialog (value dialog))) + (setf (text (fm^ :message-response)) (value dialog))))))) (loop for message-type in '(:info :warning :question :error) collect (make-kid 'test-message :message-type message-type))))) (mk-label :md-name :message-response) --- /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/29 00:00:34 1.1 +++ /project/cells/cvsroot/cells-gtk/test-gtk/test-gtk.lisp 2008/01/30 14:21:02 1.2 @@ -41,7 +41,7 @@ :kids (c? (the-kids (let ((tabs '("Buttons" "Display" - "Layout" + "Layout" "Menus" "Textview" "Dialogs" @@ -65,7 +65,7 @@ (defun gtk-demo (&optional dbg) - (ukt:test-prep) + #-iamnotkenny (ukt:test-prep) (cells-gtk-init) (cells-gtk:start-app 'test-gtk::test-gtk :debug dbg))

1 0

[cells-cvs] CVS cells-gtk
by phildebrandt 30 Jan '08

30 Jan '08

Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv6810 Modified Files: cells-gtk.asd cells3-porting-notes.lisp dialogs.lisp widgets.lisp Log Message: merging in ken's and peter's changes from Jan 29th --- /project/cells/cvsroot/cells-gtk/cells-gtk.asd 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/cells-gtk.asd 2008/01/30 14:21:01 1.2 @@ -8,6 +8,7 @@ ((:file "packages") (:file "conditions") (:file "compat") + (:file "cells3-porting-notes" :depends-on ("packages")) (:file "widgets" :depends-on ("conditions")) (:file "layout" :depends-on ("widgets")) (:file "display" :depends-on ("widgets")) --- /project/cells/cvsroot/cells-gtk/cells3-porting-notes.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/cells3-porting-notes.lisp 2008/01/30 14:21:01 1.2 @@ -20,12 +20,15 @@ (in-package :cells-gtk) -(export '(make-be kids-list?)) (defun make-be (class &rest args) - (md-awaken (apply 'make-instance class args))) + (let ((x (apply 'make-instance class args))) + (md-awaken x) + x)) -(defun to-be (x) (md-awaken x)) +(defun to-be (x) (md-awaken x) x) (defmacro kids-list? (&rest body) - `(c? (the-kids ,@body))) \ No newline at end of file + `(c? (the-kids ,@body))) + +(export '(make-be to-be kids-list?)) \ No newline at end of file --- /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 14:21:01 1.2 @@ -46,6 +46,7 @@ (message self)))) (defmethod md-awaken :after ((self message-dialog)) + (print 'md-awaken-after) (let ((response (gtk-dialog-run (id self)))) (setf (value self) (case response @@ -54,12 +55,14 @@ (-7 :close) (-8 :yes) (-9 :no)))) - (gtk-widget-destroy (id self)) - (gtk-object-forget (id self) self) (with-slots (content-area) self (when content-area (setf (value self) (value content-area)) - (gtk-object-forget (id content-area) content-area)))) + (print (value content-area)) + (gtk-object-forget (id content-area) content-area))) + (gtk-widget-destroy (id self)) + (gtk-object-forget (id self) self) + (print 'done)) (defun show-message (text &rest inits) (let ((message-widget (to-be (apply #'mk-message-dialog :message text inits)))) --- /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 14:21:01 1.2 @@ -20,7 +20,7 @@ (defmodel gtk-object (family) - ((container :cell nil :initarg :container :accessor container) + ((container :cell nil :initarg :container :accessor container :initform nil) (def-gtk-class-name :accessor def-gtk-class-name :initarg :def-gtk-class-name :initform nil) (new-function-name :accessor new-function-name :initarg :new-function-name :initform (c? (intern (format nil "GTK-~a-NEW~a"

1 0

[cells-cvs] CVS cells/utils-kt
by phildebrandt 30 Jan '08

30 Jan '08

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv6741/utils-kt Modified Files: core.lisp detritus.lisp Log Message: make utils-kt work on sbcl. Peter. --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/12/03 20:11:12 1.3 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/29 23:30:06 1.4 @@ -22,7 +22,7 @@ ,@body)) (defmacro export! (&rest symbols) - `(eval-when (:compile-toplevel :load-toplevel :execute) + `(eval-when (#-sbcl :compile-toplevel :load-toplevel :execute) (export ',symbols))) (defmacro define-constant (name value &optional docstring) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/01/29 04:29:55 1.17 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/01/29 23:30:06 1.18 @@ -70,7 +70,7 @@ (export! project-path) (defun project-path () - (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) + #+allegro (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) #+test (test-setup)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs January 2008