Author: junrue Date: Wed Nov 1 12:52:32 2006 New Revision: 388 Added: trunk/src/tests/mcclim/ trunk/src/tests/mcclim/hello-tester.lisp Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/Makefile trunk/docs/manual/gfw-symbols.xml trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/root-window.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: version bump for next release; enhanced append-item to accept an optional classname; added a few bits related to job tables; added a mcclim testcase; added convenience macro with-root-window Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Nov 1 12:52:32 2006 @@ -1,4 +1,13 @@ + +. GFW:APPEND-ITEM now accepts an optional classname argument so that + applications can use custom item classes. + +. Implemented a new macro GFW:WITH-ROOT-WINDOW which manages the lifetime + of an instance of GFW:ROOT-WINDOW for use within the macro body. + +============================================================================== + Release 0.6.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Nov 1 12:52:32 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.6.0 (22 October 2006) +Graphic-Forms README for version 0.7.0 (xx xxxxx 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Wed Nov 1 12:52:32 2006 @@ -5,7 +5,7 @@ # Copyright (c) 2006, Jack D. Unrue # -VERSION = 0.6 +VERSION = 0.7 CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml \ constants.xml api.xml \ Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Nov 1 12:52:32 2006 @@ -4518,6 +4518,13 @@ initially checked. </description> </argument> + <argument name="classname"> + <description> + A <refclhs>symbol</refclhs> specifying an item subclass other than the + default type to be created; such a subclass must still represent an + item type appropriate for <arg0/>. + </description> + </argument> </arguments> <return> <reftopic>gfw:item</reftopic> @@ -5337,7 +5344,7 @@ The <reftopic>gfw:widget</reftopic> being resized. </description> </argument> - <argument name="point"> + <argument name="size"> <description> A <reftopic>gfs:size</reftopic> indicating <arg1/>'s new dimensions. </description> @@ -5945,6 +5952,33 @@ </seealso> </macro> + <macro name="with-root-window"> + <syntax> + <arguments> + <notarg name="("/> + <argument name="window"> + <description> + A <reftopic>gfw:root-window</reftopic> to query. + </description> + </argument> + <notarg name=")"/> + <notarg name="&body"/> + <argument name="body"> + <description> + Application code to make use of <arg0/>. + </description> + </argument> + </arguments> + <return> + <emphasis>results</emphasis> + </return> + </syntax> + <description> + This macro executes <arg1/> with <arg0/> bound to an instance of + <reftopic>gfw:root-window</reftopic>. + </description> + </macro> + <macro name="with-graphics-context"> <syntax> <arguments> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Nov 1 12:52:32 2006 @@ -43,7 +43,7 @@ <p>The current version is <a href="http://sourceforge.net/project/showfiles.php?group_id=163034"> - 0.6.0</a>, released on 22 October 2006.</p> + 0.7.0</a>, released on xx xxxxxx 2006.</p> <p>Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Nov 1 12:52:32 2006 @@ -1,3 +1,5 @@ +;;; -*- Mode: Lisp -*- + ;;;; ;;;; graphic-forms-tests.asd ;;;; @@ -54,7 +56,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.6.0" + :version "0.7.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Nov 1 12:52:32 2006 @@ -1,3 +1,5 @@ +;;; -*- Mode: Lisp -*- + ;;;; ;;;; graphic-forms-uitoolkit.asd ;;;; @@ -39,7 +41,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.6.0" + :version "0.7.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") @@ -149,3 +151,6 @@ (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) + +(defmethod perform :after ((op load-op) (c (eql (find-system :graphic-forms-uitoolkit)))) + (pushnew :graphic-forms *features*)) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Nov 1 12:52:32 2006 @@ -157,7 +157,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.6"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.7"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Nov 1 12:52:32 2006 @@ -87,7 +87,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.6"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.7"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Nov 1 12:52:32 2006 @@ -540,6 +540,7 @@ #:with-file-dialog #:with-font-dialog #:with-graphics-context + #:with-root-window ;; conditions )) Added: trunk/src/tests/mcclim/hello-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/mcclim/hello-tester.lisp Wed Nov 1 12:52:32 2006 @@ -0,0 +1,37 @@ + +(defpackage :clim-graphic-forms-tests + (:use :clim :clim-lisp)) + +(in-package :clim-graphic-forms-tests) + +(define-application-frame hello-frame () + ((message :initform "Foo!" :accessor message)) + (:menu-bar menubar-command-table) + (:panes (some-pane :application :display-function 'display-some-pane)) + (:layouts (default + (vertically (:height 500 :width 400) + (:fill some-pane))))) + +(define-command com-hello () + (clim-graphic-forms::debug-print "com-hello called ") + (setf (message *application-frame*) "Hello there!")) + +(define-command com-hi () + (clim-graphic-forms::debug-print "com-hi called ") + (setf (message *application-frame*) "Hi there!")) + +(define-command-table menu-command-table + :menu (("Hello" :command com-hello) + ("Howdy" :command com-hi))) + +(define-command-table menubar-command-table + :menu (("Menu" :menu menu-command-table) + ("Quit" :command com-quit-frame))) + +(define-hello-frame-command (com-quit-frame :name "Quit" :menu t) + () + (frame-exit *application-frame*)) + +(defmethod display-some-pane ((frame hello-frame) stream) + (clim-graphic-forms::debug-print "display-some-pane called ") + (format stream (message frame))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Wed Nov 1 12:52:32 2006 @@ -120,8 +120,8 @@ (if items (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item)))) -(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled) - (declare (ignore disabled checked)) +(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled classname) + (declare (ignore disabled checked classname)) (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp))) (vector-push-extend item (slot-value self 'gfw::items)) item)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Nov 1 12:52:32 2006 @@ -47,6 +47,8 @@ (defconstant +wm-user+ #x0400) (defconstant +wm-app+ #x8000) +(defconstant +wm-job-posting+ #x2112) + (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Nov 1 12:52:32 2006 @@ -85,8 +85,8 @@ ;;; methods ;;; -(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled) - (declare (ignore thing disp checked disabled)) +(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled classname) + (declare (ignore thing disp checked disabled classname)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Nov 1 12:52:32 2006 @@ -169,12 +169,12 @@ ;;; methods ;;; -(defmethod append-item ((self list-box) thing disp &optional disabled checked) +(defmethod append-item ((self list-box) thing disp &optional disabled checked classname) (declare (ignore disabled checked)) (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol 'list-item thing disp))) + (item (create-item-with-callback hcontrol (or classname 'list-item) thing disp))) (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (slot-value self 'items)) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Nov 1 12:52:32 2006 @@ -90,10 +90,10 @@ ;;; methods ;;; -(defmethod append-item ((self menu) thing disp &optional disabled checked) +(defmethod append-item ((self menu) thing disp &optional disabled checked classname) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu 'menu-item thing disp)) + (item (create-item-with-callback hmenu (or classname 'menu-item) thing disp)) (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) Modified: trunk/src/uitoolkit/widgets/root-window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/root-window.lisp (original) +++ trunk/src/uitoolkit/widgets/root-window.lisp Wed Nov 1 12:52:32 2006 @@ -34,6 +34,17 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; macros and helper functions +;;; + +(defmacro with-root-window ((win) &body body) + `(let ((,win (make-instance 'root-window))) + (unwind-protect + (progn + ,@body) + (gfs:dispose ,win)))) + +;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Nov 1 12:52:32 2006 @@ -45,6 +45,7 @@ (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-item-id :initform 10000 :reader next-item-id) + (next-job-id :initform 1 :reader next-job-id) (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) @@ -112,6 +113,9 @@ (defgeneric put-item (self item)) (defgeneric delete-tc-item (self item)) (defgeneric increment-item-id (self)) +(defgeneric put-job (self id closure)) +(defgeneric take-job (self id)) +(defgeneric increment-job-id (self)) (defgeneric get-timer (self id)) (defgeneric put-timer (self timer)) (defgeneric delete-timer (self timer)) @@ -225,6 +229,22 @@ (incf (slot-value tc 'next-item-id)) id)) +(defmethod put-job ((tc thread-context) id closure) + "Stores a closure using the specified ID for later retrieval." + ;; FIXME: thread-safety + (setf (gethash id (slot-value tc 'job-table)) closure)) + +(defmethod take-job ((tc thread-context) id) + (let ((closure (gethash id (slot-value tc 'job-table)))) + (remhash id (slot-value tc 'job-table)) + closure)) + +(defmethod increment-job-id ((tc thread-context)) + "Return the next job ID; also increment the internal value." + (let ((id (next-job-id tc))) + (incf (slot-value tc 'next-job-id)) + id)) + (defmethod get-timer ((tc thread-context) id) "Returns the timer identified by the specified (system-defined) id." (gethash id (slot-value tc 'timers-by-id))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Nov 1 12:52:32 2006 @@ -45,7 +45,7 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self thing dispatcher &optional checked disabled) +(defgeneric append-item (self thing dispatcher &optional checked disabled classname) (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item.")) (defgeneric append-separator (self)