- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r456 - in branches/graphic-forms-newtypes: . docs/manual src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Mon Apr 2 22:37:00 2007 New Revision: 456 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Log: implemented new top-level style :fixed-size and modified gfw:pack to set min and max sizes when :fixed-size has been set; added another optional parameter to CREATE-CONTROL convenience function to allow control initializers to pass params to their implementations of COMPUTE-STYLE-FLAGS Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Mon Apr 2 22:37:00 2007 @@ -3,6 +3,14 @@ stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). +. Implemented simple-mode status bars, which have a single text field. + Multi-part status bars, and nested widget support, will be added in a + future release. + +. Simplified the mechanism for specifying fixed, non-resizable windows by + adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK + to do the right thing if that style flag has been specified. + . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. Modified: branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml ============================================================================== --- branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml (original) +++ branches/graphic-forms-newtypes/docs/manual/gfw-symbols.xml Mon Apr 2 22:37:00 2007 @@ -1419,6 +1419,12 @@ </enum> One or more of the following optional styles: <enum> + <argument name=":fixed-size"> + <description> + The resulting window cannot be dragged to a new size, but a layout + manager can still resize it programmatically. + </description> + </argument> <argument name=":horizontal-scrollbar"/> <argument name=":status-bar"/> <argument name=":vertical-scrollbar"/> Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp (original) +++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp Mon Apr 2 22:37:00 2007 @@ -112,7 +112,7 @@ :style :vertical :spacing +spacing+ :margins +margin+) - :style '(:workspace :status-bar))) + :style '(:fixed-size :workspace :status-bar))) (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win* @@ -126,10 +126,7 @@ :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "UnBlocked") - (setf (gfw:resizable-p *unblocked-win*) nil) - (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size - (gfw:maximum-size *unblocked-win*) size)) + (gfw:pack *unblocked-win*) (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/control.lisp Mon Apr 2 22:37:00 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; control.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -45,10 +45,10 @@ (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0)) (warn 'gfs:win32-warning :detail "init-common-controls failed")))) -(defun create-control (ctrl parent text icc-flags &optional id) +(defun create-control (ctrl parent text icc-flags &optional id extra-data) (initialize-comctl-classes icc-flags) (multiple-value-bind (std-style ex-style) - (compute-style-flags ctrl) + (compute-style-flags ctrl extra-data) (let ((hwnd (create-window (system-classname-of ctrl) (or text " ") (gfs:handle parent) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp Mon Apr 2 22:37:00 2007 @@ -104,11 +104,16 @@ (max (first widths) (second widths)))) (defmethod compute-style-flags ((self status-bar) &rest extra-data) - (declare (ignore extra-data)) - (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) + (let ((extra-bits (if (first extra-data) 0 gfs::+sbars-sizegrip+))) + (values (logior gfs::+ws-child+ gfs::+ws-visible+ extra-bits) 0))) (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) - (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+))) + (let ((hctl (create-control self + parent + "" + gfs::+icc-win95-classes+ + nil + (find :fixed-size (style-of parent))))) (gfs::send-message hctl gfs::+sb-simple+ 1 0)) (let ((widths (stb-get-border-widths self))) (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Mon Apr 2 22:37:00 2007 @@ -111,13 +111,10 @@ ;; styles that can be combined ;; -#| - (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) - (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# + (:fixed-size + (setf std-flags (logand std-flags + (lognot (logior gfs::+ws-maximizebox+ + gfs::+ws-thickframe+))))) (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) (:status-bar) ;; nothing to do, but need to allow this style symbol @@ -198,6 +195,13 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) +(defmethod pack ((win window)) + (if (find :fixed-size (style-of win)) + (let ((size (gfw:preferred-size win -1 -1))) + (setf (gfw:minimum-size win) size + (gfw:maximum-size win) size))) + (call-next-method)) + (defmethod preferred-size ((self top-level) width-hint height-hint) (declare (ignore width-hint height-hint)) (let ((size (call-next-method))

1 0

[graphic-forms-cvs] r455 - in trunk/src: demos/unblocked uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sun Apr 1 00:30:42 2007 New Revision: 455 Modified: trunk/src/demos/unblocked/unblocked-controller.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/status-bar.lisp Log: implemented text and (setf text) for status-bar; unblocked now displays shape count and points scored via status-bar messages Modified: trunk/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-controller.lisp (original) +++ trunk/src/demos/unblocked/unblocked-controller.lisp Sun Apr 1 00:30:42 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; unblocked-controller.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -37,11 +37,13 @@ (defun ctrl-start-game () (model-new) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) (defun ctrl-restart-game () (model-rollback) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) @@ -82,10 +84,17 @@ (let ((tile-pnt (window->tiles point))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (let ((prev-level (model-level))) + (let ((prev-level (model-level)) + (orig-score (score-of *game*))) (update-model-score shape-pnts) + (update-status-bar (format nil + "Removed ~d tiles for ~d points." + (length shape-pnts) + (- (score-of *game*) orig-score))) (if (> (model-level) prev-level) + (progn (regenerate-model-tiles) + (update-status-bar "Ready.")) (update-model-tiles shape-pnts)) (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Apr 1 00:30:42 2007 @@ -61,6 +61,10 @@ (update-buffer (gfw:dispatcher panel)) (gfw:redraw panel)) +(defun update-status-bar (msg) + (if *unblocked-win* + (setf (gfw:text (gfw:status-bar-of *unblocked-win*)) msg))) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (ctrl-reveal-move)) @@ -129,7 +133,8 @@ (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) - (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) + (setf (gfw:image *unblocked-win*) + (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Apr 1 00:30:42 2007 @@ -127,3 +127,9 @@ (widths (stb-get-border-widths self))) (gfs:make-size :width 0 :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1)))) + +(defmethod text ((sbar status-bar)) + (stb-get-text sbar 0)) + +(defmethod (setf text) (str (sbar status-bar)) + (stb-set-text sbar str))

1 0

[graphic-forms-cvs] r454 - in branches/graphic-forms-newtypes/src: demos/unblocked uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sun Apr 1 00:30:17 2007 New Revision: 454 Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp Log: implemented text and (setf text) for status-bar; unblocked now displays shape count and points scored via status-bar messages Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp (original) +++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-controller.lisp Sun Apr 1 00:30:17 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; unblocked-controller.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -37,11 +37,13 @@ (defun ctrl-start-game () (model-new) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) (defun ctrl-restart-game () (model-rollback) + (update-status-bar "Ready.") (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) @@ -82,10 +84,17 @@ (let ((tile-pnt (window->tiles point))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (let ((prev-level (model-level))) + (let ((prev-level (model-level)) + (orig-score (score-of *game*))) (update-model-score shape-pnts) + (update-status-bar (format nil + "Removed ~d tiles for ~d points." + (length shape-pnts) + (- (score-of *game*) orig-score))) (if (> (model-level) prev-level) - (regenerate-model-tiles) + (progn + (regenerate-model-tiles) + (update-status-bar "Ready.")) (update-model-tiles shape-pnts)) (update-panel (get-scoreboard-panel)) (update-panel (get-tiles-panel))) Modified: branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp (original) +++ branches/graphic-forms-newtypes/src/demos/unblocked/unblocked-window.lisp Sun Apr 1 00:30:17 2007 @@ -61,6 +61,10 @@ (update-buffer (gfw:dispatcher panel)) (gfw:redraw panel)) +(defun update-status-bar (msg) + (if *unblocked-win* + (setf (gfw:text (gfw:status-bar-of *unblocked-win*)) msg))) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (ctrl-reveal-move)) @@ -129,7 +133,8 @@ (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) - (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) + (setf (gfw:image *unblocked-win*) + (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/status-bar.lisp Sun Apr 1 00:30:17 2007 @@ -127,3 +127,9 @@ (widths (stb-get-border-widths self))) (gfs:make-size :width 0 :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1)))) + +(defmethod text ((sbar status-bar)) + (stb-get-text sbar 0)) + +(defmethod (setf text) (str (sbar status-bar)) + (stb-set-text sbar str))

1 0

[graphic-forms-cvs] r453 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sat Mar 31 23:02:09 2007 New Revision: 453 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: stop double-counting status-bar height; add additional testcase Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Mar 31 23:02:09 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-tester.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -275,7 +275,7 @@ (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events) :layout (make-instance 'gfw:heap-layout) - :style '(:frame))) + :style '(:frame :status-bar))) (let* ((layout (gfw:layout-of *widget-tester-win*)) (test-panels (list (populate-list-box-test-panel) (populate-slider-test-panel))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sat Mar 31 23:02:09 2007 @@ -122,9 +122,6 @@ (let ((kid-count (length (data-of self))) (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) - (sbar-height (if (status-bar-of container) - (gfs:size-height (preferred-size (status-bar-of container) -1 -1)) - 0)) (vertical (find :vertical (style-of self))) (horizontal (find :horizontal (style-of self)))) (let ((spacing-total (* (spacing-of self) (1- kid-count))) @@ -140,16 +137,14 @@ (gfs:make-size :width (+ (flow-data-distance-total state) horz-margin-total spacing-total) - :height (- (+ (flow-data-max-extent state) - vert-margin-total) - sbar-height))) + :height (+ (flow-data-max-extent state) + vert-margin-total))) (vertical (gfs:make-size :width (+ (flow-data-max-extent state) horz-margin-total) - :height (- (+ (flow-data-distance-total state) + :height (+ (flow-data-distance-total state) vert-margin-total - spacing-total) - sbar-height))) + spacing-total))) (t (error 'gfs:toolkit-error :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Mar 31 23:02:09 2007 @@ -68,14 +68,6 @@ ;;; methods ;;; -(defmethod compute-outer-size ((self top-level) desired-client-size) - (declare (ignore desired-client-size)) - (let ((size (call-next-method)) - (sbar (status-bar-of self))) - (if sbar - (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) - size)) - (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Mar 31 23:02:09 2007 @@ -75,7 +75,7 @@ (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) + (unless (or (null parent) (null child) (typep child 'status-bar)) (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) (tmp-list (child-visitor-results tc))) (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)

1 0

[graphic-forms-cvs] r452 - in branches/graphic-forms-newtypes/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 01 Apr '07

01 Apr '07

Author: junrue Date: Sat Mar 31 23:01:47 2007 New Revision: 452 Modified: branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Log: stop double-counting status-bar height; add additional testcase Modified: branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp (original) +++ branches/graphic-forms-newtypes/src/tests/uitoolkit/widget-tester.lisp Sat Mar 31 23:01:47 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-tester.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -275,7 +275,7 @@ (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events) :layout (make-instance 'gfw:heap-layout) - :style '(:frame))) + :style '(:frame :status-bar))) (let* ((layout (gfw:layout-of *widget-tester-win*)) (test-panels (list (populate-list-box-test-panel) (populate-slider-test-panel))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/flow-layout.lisp Sat Mar 31 23:01:47 2007 @@ -122,9 +122,6 @@ (let ((kid-count (length (data-of self))) (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) - (sbar-height (if (status-bar-of container) - (gfs:size-height (preferred-size (status-bar-of container) -1 -1)) - 0)) (vertical (find :vertical (style-of self))) (horizontal (find :horizontal (style-of self)))) (let ((spacing-total (* (spacing-of self) (1- kid-count))) @@ -140,16 +137,14 @@ (gfs:make-size :width (+ (flow-data-distance-total state) horz-margin-total spacing-total) - :height (- (+ (flow-data-max-extent state) - vert-margin-total) - sbar-height))) + :height (+ (flow-data-max-extent state) + vert-margin-total))) (vertical (gfs:make-size :width (+ (flow-data-max-extent state) horz-margin-total) - :height (- (+ (flow-data-distance-total state) - vert-margin-total - spacing-total) - sbar-height))) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) (t (error 'gfs:toolkit-error :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Sat Mar 31 23:01:47 2007 @@ -68,14 +68,6 @@ ;;; methods ;;; -(defmethod compute-outer-size ((self top-level) desired-client-size) - (declare (ignore desired-client-size)) - (let ((size (call-next-method)) - (sbar (status-bar-of self))) - (if sbar - (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) - size)) - (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Sat Mar 31 23:01:47 2007 @@ -75,7 +75,7 @@ (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) - (unless (or (null parent) (null child)) + (unless (or (null parent) (null child) (typep child 'status-bar)) (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) (tmp-list (child-visitor-results tc))) (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd)

1 0

[graphic-forms-cvs] r451 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Mar '07

30 Mar '07

Author: junrue Date: Thu Mar 29 22:26:46 2007 New Revision: 451 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: when processing WM_CTLCOLOR* messages, call the default wndproc rather than returning 0 Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Mar 29 22:26:46 2007 @@ -145,18 +145,17 @@ 0)))) (defun process-ctlcolor-message (wparam lparam) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) - (hdc (cffi:make-pointer wparam)) - (bkgdcolor (brush-color-of widget)) - (textcolor (text-color-of widget)) - (ret-val 0)) - (when widget + (let ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) + (hdc (cffi:make-pointer wparam))) + (if widget + (let ((bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget))) (if bkgdcolor (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) (if textcolor (gfs::set-text-color hdc (gfg:color->rgb textcolor))) - (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) - ret-val)) + (cffi:pointer-address (brush-handle-of widget))) + 0))) (defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget)) @@ -425,20 +424,28 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) (let* ((widget (get-widget (thread-context) hwnd))

1 0

[graphic-forms-cvs] r450 - branches/graphic-forms-newtypes/src/uitoolkit/widgets
by junrue＠common-lisp.net 30 Mar '07

30 Mar '07

Author: junrue Date: Thu Mar 29 22:26:27 2007 New Revision: 450 Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Log: when processing WM_CTLCOLOR* messages, call the default wndproc rather than returning 0 Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Thu Mar 29 22:26:27 2007 @@ -145,18 +145,17 @@ 0)))) (defun process-ctlcolor-message (wparam lparam) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) - (hdc (cffi:make-pointer wparam)) - (bkgdcolor (brush-color-of widget)) - (textcolor (text-color-of widget)) - (ret-val 0)) - (when widget - (if bkgdcolor - (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) - (if textcolor - (gfs::set-text-color hdc (gfg:color->rgb textcolor))) - (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) - ret-val)) + (let ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) + (hdc (cffi:make-pointer wparam))) + (if widget + (let ((bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget))) + (if bkgdcolor + (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) + (if textcolor + (gfs::set-text-color hdc (gfg:color->rgb textcolor))) + (cffi:pointer-address (brush-handle-of widget))) + 0))) (defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget)) @@ -425,20 +424,28 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) (let* ((widget (get-widget (thread-context) hwnd))

1 0

[graphic-forms-cvs] r449 - in trunk/src/uitoolkit: system widgets
by junrue＠common-lisp.net 30 Mar '07

30 Mar '07

Author: junrue Date: Thu Mar 29 20:05:58 2007 New Revision: 449 Modified: trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/window.lisp Log: completed change-over to stdcall support offered by CFFI Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Mar 29 20:05:58 2007 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.system) (eval-when (:compile-toplevel :load-toplevel :execute) - (use-package :cffi)) + (use-package :cffi) +#+cffi-features:no-stdcall + (error "Graphic-Forms requires stdcall support enabled in CFFI.")) (load-foreign-library "user32.dll") @@ -206,7 +208,6 @@ (hwnd HANDLE) (ps LPTR)) -#-cffi-features:no-stdcall (defcfun ("EnumChildWindows" enum-child-windows :cconv :stdcall) INT @@ -214,15 +215,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-child-windows "EnumChildWindows") - ((hwnd :pointer) - (func :pointer) - (lparam :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) INT @@ -231,16 +223,6 @@ (enumproc LPTR) (data LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-display-monitors "EnumDisplayMonitors") - ((hdc :pointer) - (cliprect :pointer) - (enumproc :pointer) - (data :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) INT @@ -248,14 +230,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-thread-windows "EnumThreadWindows") - ((threadid (:unsigned :long)) - (func :pointer) - (lparam :long)) - :result-type :int) - (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu Mar 29 20:05:58 2007 @@ -37,30 +37,16 @@ ;;; helper functions ;;; -#-cffi-features:no-stdcall (cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) -#+lispworks -(fli:define-foreign-callable - ("display_visitor" :result-type :integer :calling-convention :stdcall) - ((hmonitor :pointer) - (hdc :pointer) - (monitorrect :pointer) - (data :long)) - (declare (ignore hdc monitorrect)) - (call-display-visitor-func (thread-context) hmonitor data) - 1) - (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor gfs::work - gfs::flags gfs::device) - mi-ptr gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::flags) mi-ptr gfs::monitorinfoex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::monitorinfoex)) (if (zerop (gfs::get-monitor-info hmonitor mi-ptr)) (error 'gfs:win32-warning :detail "get-monitor-info failed")) @@ -88,13 +74,9 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-display-monitors (cffi:null-pointer) (cffi:null-pointer) (cffi:callback display-visitor) 0) -#+lispworks - (let ((ptr (fli:make-pointer :address 0))) - (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -109,7 +91,6 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#-cffi-features:no-stdcall (cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) @@ -119,14 +100,6 @@ (call-top-level-visitor-func tc win))) 1) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (top-level-window-visitor hwnd lparam) - 1) - (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -135,13 +108,8 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (cffi:callback top-level-window-visitor) - 0) -#+lispworks - (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Mar 29 20:05:58 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; thread-context.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Mar 29 20:05:58 2007 @@ -70,7 +70,6 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -#-cffi-features:no-stdcall (cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) @@ -83,14 +82,6 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) -#+lispworks -(fli:define-foreign-callable - ("child_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (child-window-visitor hwnd lparam) - 1) - (defun window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -326,14 +317,9 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-child-windows hwnd (cffi:callback child-window-visitor) (cffi:pointer-address hwnd)) -#+lispworks - (gfs::enum-child-windows hwnd - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil)

1 0

[graphic-forms-cvs] r448 - in branches/graphic-forms-newtypes/src/uitoolkit: system widgets
by junrue＠common-lisp.net 30 Mar '07

30 Mar '07

Author: junrue Date: Thu Mar 29 20:05:44 2007 New Revision: 448 Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Log: completed change-over to stdcall support offered by CFFI Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp Thu Mar 29 20:05:44 2007 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.system) (eval-when (:compile-toplevel :load-toplevel :execute) - (use-package :cffi)) + (use-package :cffi) +#+cffi-features:no-stdcall + (error "Graphic-Forms requires stdcall support enabled in CFFI.")) (load-foreign-library "user32.dll") @@ -206,7 +208,6 @@ (hwnd HANDLE) (ps LPTR)) -#-cffi-features:no-stdcall (defcfun ("EnumChildWindows" enum-child-windows :cconv :stdcall) INT @@ -214,15 +215,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-child-windows "EnumChildWindows") - ((hwnd :pointer) - (func :pointer) - (lparam :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) INT @@ -231,16 +223,6 @@ (enumproc LPTR) (data LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-display-monitors "EnumDisplayMonitors") - ((hdc :pointer) - (cliprect :pointer) - (enumproc :pointer) - (data :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) INT @@ -248,14 +230,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-thread-windows "EnumThreadWindows") - ((threadid (:unsigned :long)) - (func :pointer) - (lparam :long)) - :result-type :int) - (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp Thu Mar 29 20:05:44 2007 @@ -37,30 +37,16 @@ ;;; helper functions ;;; -#-cffi-features:no-stdcall (cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) -#+lispworks -(fli:define-foreign-callable - ("display_visitor" :result-type :integer :calling-convention :stdcall) - ((hmonitor :pointer) - (hdc :pointer) - (monitorrect :pointer) - (data :long)) - (declare (ignore hdc monitorrect)) - (call-display-visitor-func (thread-context) hmonitor data) - 1) - (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor gfs::work - gfs::flags gfs::device) - mi-ptr gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::flags) mi-ptr gfs::monitorinfoex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::monitorinfoex)) (if (zerop (gfs::get-monitor-info hmonitor mi-ptr)) (error 'gfs:win32-warning :detail "get-monitor-info failed")) @@ -88,13 +74,9 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-display-monitors (cffi:null-pointer) (cffi:null-pointer) (cffi:callback display-visitor) 0) -#+lispworks - (let ((ptr (fli:make-pointer :address 0))) - (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -109,7 +91,6 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#-cffi-features:no-stdcall (cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) @@ -119,14 +100,6 @@ (call-top-level-visitor-func tc win))) 1) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (top-level-window-visitor hwnd lparam) - 1) - (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -135,14 +108,9 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (cffi:callback top-level-window-visitor) 0) -#+lispworks - (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") - 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp Thu Mar 29 20:05:44 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; thread-context.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Thu Mar 29 20:05:44 2007 @@ -70,7 +70,6 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -#-cffi-features:no-stdcall (cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) @@ -83,14 +82,6 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) -#+lispworks -(fli:define-foreign-callable - ("child_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (child-window-visitor hwnd lparam) - 1) - (defun window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -326,14 +317,9 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-child-windows hwnd (cffi:callback child-window-visitor) (cffi:pointer-address hwnd)) -#+lispworks - (gfs::enum-child-windows hwnd - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil)

1 0

[graphic-forms-cvs] r447 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Mar '07

28 Mar '07

Author: junrue Date: Wed Mar 28 00:26:10 2007 New Revision: 447 Modified: trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: revised thread context and startup implementation to use Allegro MT support Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Mar 28 00:26:10 2007 @@ -65,12 +65,10 @@ ;; ;; TODO: change this once we understand SBCL MT support ;; -;; TODO: support Allegro MT -;; -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defvar *the-thread-context* nil) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun thread-context () (when (null *the-thread-context*) (setf *the-thread-context* (make-instance 'thread-context)) @@ -81,13 +79,39 @@ (format *error-output* "~a~%" e)))) *the-thread-context*) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun dispose-thread-context () (let ((hwnd (utility-hwnd *the-thread-context*))) (unless (gfs:null-handle-p hwnd) (gfs::destroy-window hwnd))) (setf *the-thread-context* nil)) +#+allegro +(eval-when (:compile-top-level :load-top-level :execute) (require :process)) + +#+allegro +(defun thread-context () + (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) tc) + (handler-case + (init-utility-hwnd tc) + (gfs:win32-error (e) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil) + (format *error-output* "~a~%" e)))) + tc)) + +#+allegro +(defun dispose-thread-context () + (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil)) + + #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 28 00:26:10 2007 @@ -87,12 +87,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun startup (thread-name start-fn) (declare (ignore thread-name)) (funcall start-fn) (message-loop #'default-message-filter)) +#+allegro +(eval-when (:compile-top-level :load-top-level :execute) (require :process)) + +#+allegro +(defun startup (thread-name start-fn) + (mp:process-run-function thread-name + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) + #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action)

1 0