[graphic-forms-cvs] r120 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun May 7 21:21:44 UTC 2006
Author: junrue
Date: Sun May 7 17:21:43 2006
New Revision: 120
Modified:
trunk/README.txt
trunk/docs/manual/api.texinfo
trunk/docs/manual/reference.texinfo
trunk/src/packages.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/timer.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
rewrote timer such that TimerProc is no longer used; rename running-p method to enabled-p
Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt (original)
+++ trunk/README.txt Sun May 7 17:21:43 2006
@@ -1,5 +1,5 @@
-Graphic-Forms README for version 0.3.0
+Graphic-Forms README for version 0.4.0
Copyright (c) 2006, Jack D. Unrue
Graphic-Forms is a user interface library implemented in Common Lisp focusing
@@ -47,32 +47,25 @@
features in general that are not yet implemented, this section lists
known problems in this release:
-1. The following bug filed against CLISP 2.38
-
- http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1355&atid=101355
-
- may result in intermittent GPFs when windows with layout managers are
- resized or when timer objects are enabled.
-
-2. Image loading currently requires installation of the ImageMagick
+1. Image loading currently requires installation of the ImageMagick
library as described in the next section. I have tested with Windows
BMP files (and this is what the image-tester application displays).
ImageMagick itself supports many image formats, but Graphic-Forms
has not been tested with all of them. Therefore, images may not
display properly, expecially when a transparency is selected.
-3. The event-tester application's menu definition specifies that the
+2. The event-tester application's menu definition specifies that the
Test Menu | Submenu | Item A item should be disabled but it does
not get disabled. However, the GFW:ENABLE function does otherwise
work correctly for menu items.
-4. The src/demos/unblocked directory contains a start at a demo
+3. The src/demos/unblocked directory contains a start at a demo
program (a simple game where one clicks on block shapes to
score points, where the rest of the blocks fall down to fill
in the gaps). This demo program is not yet finished, but the
source code can still serve as sample code.
-5. The text-extent generic function currently does not return
+4. The text-extent generic function currently does not return
the correct text height. As a workaround, get the text metrics
for the desired font and base height calculations on that
value. The text-extent function does return the correct width.
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sun May 7 17:21:43 2006
@@ -870,10 +870,6 @@
Causes the entire bounds of the object to be marked as needing to be redrawn
@end deffn
- at deffn GenericFunction running-p self
-Returns T if the object is in event generation mode; nil otherwise.
- at end deffn
-
@deffn GenericFunction show self flag
Causes the object to be visible or hidden on the screen, but not
necessarily top-most in the display z-order.
Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo (original)
+++ trunk/docs/manual/reference.texinfo Sun May 7 17:21:43 2006
@@ -126,7 +126,7 @@
@titlepage
@title Graphic-Forms Programming Reference
- at c @subtitle Version 0.3
+ at c @subtitle Version 0.4
@c @author Jack D. Unrue
@page
@@ -136,7 +136,7 @@
@ifnottex
@node Top
- at top Graphic-Forms Programming Reference (version 0.3)
+ at top Graphic-Forms Programming Reference (version 0.4)
@insertcopying
@end ifnottex
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun May 7 17:21:43 2006
@@ -445,7 +445,6 @@
#:retrieve-span
#:right-margin-of
#:run-default-message-loop
- #:running-p
#:scroll
#:select
#:select-all
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun May 7 17:21:43 2006
@@ -505,46 +505,13 @@
(by-pos BOOL)
(item-info LPTR))
-;;; FIXME: uncomment this when CFFI callbacks can
-;;; be tagged as stdcall or cdecl (only the latter
-;;; is supported as of 0.9.0)
-;;;
-#|
(defcfun
("SetTimer" set-timer)
UINT
(hwnd HANDLE)
(id UINT)
(elapse UINT)
- (callback :pointer)) ;; TIMERPROC
-|#
-
-#+lispworks
-(fli:define-foreign-function
- (set-timer "SetTimer")
- ((hwnd :pointer)
- (id :unsigned-int)
- (elapse :unsigned-int)
- (func :pointer))
- :result-type :unsigned-int)
-
-#+clisp
-(ffi:def-call-out set-timer
- (:name "SetTimer")
- (:library "user32.dll")
- (:language :stdc)
- (:arguments (hwnd ffi:c-pointer)
- (id ffi:uint)
- (elapse ffi:uint)
- (func (ffi:c-function
- (:arguments
- (hwnd ffi:c-pointer)
- (msg ffi:uint)
- (id ffi:uint)
- (time ffi:long))
- (:return-type nil)
- (:language :stdc-stdcall))))
- (:return-type ffi:uint))
+ (callback :pointer)) ;; TIMERPROC (requires _stdcall, do not use yet)
;;; SetWindowLong is deprecated in favor of SetWindowLongPtr
;;; which can be used to write code compatible to both Win32
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Sun May 7 17:21:43 2006
@@ -407,11 +407,11 @@
0)))
(defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam)
- (declare (ignore hwnd lparam))
+ (declare (ignore lparam))
(let* ((tc (thread-context))
(timer (get-timer tc wparam)))
(if (null timer)
- (gfs::kill-timer (cffi:null-pointer) wparam)
+ (gfs::kill-timer hwnd wparam)
(progn
(if (<= (delay-of timer) 0)
(enable timer nil)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun May 7 17:21:43 2006
@@ -45,9 +45,11 @@
(mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)
(move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt)
(next-menuitem-id :initform 10000 :reader next-menuitem-id)
+ (next-timer-id :initform 1 :reader next-timer-id)
(size-event-size :initform (gfs:make-size) :accessor size-event-size)
(widgets-by-hwnd :initform (make-hash-table :test #'equal))
(timers-by-id :initform (make-hash-table :test #'equal))
+ (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd)
(wip :initform nil))
(:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
@@ -56,20 +58,46 @@
#+clisp (defvar *the-thread-context* nil)
#+clisp (defun thread-context ()
+ (when (null *the-thread-context*)
+ (setf *the-thread-context* (make-instance 'thread-context))
+ (init-utility-hwnd *the-thread-context*))
*the-thread-context*)
#+clisp (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))
#+lispworks (defun thread-context ()
(let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context)))
(when (null tc)
(setf tc (make-instance 'thread-context))
- (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc))
+ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)
+ (init-utility-hwnd tc))
tc))
#+lispworks (defun dispose-thread-context ()
+ (let ((tc (getf (mp:process-plist 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-plist mp:*current-process*) 'thread-context) nil))
+
+(defmethod init-utility-hwnd ((tc thread-context))
+ (register-toplevel-noerasebkgnd-window-class)
+ (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here
+ "" ; because of circular dependency
+ (cffi:null-pointer)
+ (logior gfs::+ws-clipchildren+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-border+
+ gfs::+ws-popup+)
+ 0)))
+ (if (gfs:null-handle-p hwnd)
+ (error 'gfs:win32-error :detail "create-window failed"))
+ (setf (slot-value tc 'utility-hwnd) hwnd)))
(defmethod call-child-visitor-func ((tc thread-context) parent child)
"Call the closure at the top of the child window visitor function stack."
@@ -163,3 +191,9 @@
(if (eql k (id-of timer))
(remhash k (slot-value tc 'timers-by-id))))
(slot-value tc 'timers-by-id)))
+
+(defmethod increment-timer-id ((tc thread-context))
+ "Return the next timer ID; also increment the internal value."
+ (let ((id (next-timer-id tc)))
+ (incf (slot-value tc 'next-timer-id))
+ id))
Modified: trunk/src/uitoolkit/widgets/timer.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/timer.lisp (original)
+++ trunk/src/uitoolkit/widgets/timer.lisp Sun May 7 17:21:43 2006
@@ -33,39 +33,6 @@
(in-package :graphic-forms.uitoolkit.widgets)
-#+lispworks
-(fli:define-foreign-callable
- ("timer_proc" :result-type :void :calling-convention :stdcall)
- ((hwnd :pointer)
- (msg :unsigned-int)
- (id :unsigned-int)
- (time :long))
- (process-message hwnd gfs::+wm-timer+ id time))
-
-#+lispworks
-(defun gf-set-timer (delay)
- (gfs::set-timer (cffi:null-pointer)
- 0 delay
- (fli:make-pointer :symbol-name "timer_proc")))
-
-#+clisp
-(defun timer_proc (hwnd msg id time)
- (declare (ignore msg))
- (process-message hwnd gfs::+wm-timer+ id time)
- nil)
-
-#+clisp
-(defun gf-set-timer (delay)
- (gfs::set-timer nil 0 delay #'timer_proc))
-
-(defun reset-timer-to-delay (timer delay)
- (remove-timer (thread-context) timer)
- (let ((id (gf-set-timer delay)))
- (if (zerop id)
- (error 'gfs:win32-error :detail "set-timer failed"))
- (setf (slot-value timer 'id) id)
- (put-timer (thread-context) timer)))
-
(defun clamp-delay-values (init-delay delay)
"Adjust delay settings based on system-defined limits."
;;
@@ -85,18 +52,23 @@
(setf delay gfs::+user-timer-maximum+))
(values init-delay delay))
-(defmethod (setf delay-of) :around (value (self timer))
- (multiple-value-bind (init-delay delay)
- (clamp-delay-values 0 value)
+(defun reset-timer-to-delay (timer delay)
+ (if (and (> (id-of timer) 0) (= (delay-of timer) delay))
+ (return-from reset-timer-to-delay nil))
+ (multiple-value-bind (init-delay clamped)
+ (clamp-delay-values 0 delay)
(declare (ignore init-delay))
- (if (/= delay (slot-value self 'delay))
- (setf (slot-value self 'delay) delay)
- (let ((tc (thread-context))
- (new-id (gf-set-timer delay)))
- (unless (or (not (running-p self)) (= new-id (id-of self)))
- (remove-timer tc self)
- (put-timer tc self))
- (setf (slot-value self 'id-of) new-id)))))
+ (let ((tc (thread-context))
+ (id (id-of timer)))
+ (when (zerop id)
+ (setf (slot-value timer 'id) (increment-timer-id tc))
+ (put-timer tc timer))
+ (if (zerop (gfs::set-timer (utility-hwnd tc) (id-of timer) clamped (cffi:null-pointer)))
+ (error 'gfs:win32-error :detail "set-timer failed")))
+ clamped))
+
+(defmethod (setf delay-of) :around (value (self timer))
+ (setf (slot-value self 'delay) (reset-timer-to-delay self value)))
(defmethod initialize-instance :after ((self timer) &key)
(if (null (delay-of self))
@@ -118,8 +90,8 @@
(let ((init-delay (initial-delay-of self)))
(if (> init-delay 0)
(reset-timer-to-delay self init-delay)
- (reset-timer-to-delay self (delay-of self)))))
+ (setf (delay-of self) (delay-of self)))))
(remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick
-(defmethod running-p ((self timer))
+(defmethod enabled-p ((self timer))
(get-timer (thread-context) (id-of self)))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun May 7 17:21:43 2006
@@ -279,9 +279,6 @@
(defgeneric retrieve-span (self)
(:documentation "Returns the span object indicating the range of values that are valid for the object."))
-(defgeneric running-p (self)
- (:documentation "Returns T if the object is in event generation mode; nil otherwise."))
-
(defgeneric scroll (self dest-pnt src-rect children-too)
(:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun May 7 17:21:43 2006
@@ -36,7 +36,6 @@
#+clisp (defun startup (thread-name start-fn)
(declare (ignore thread-name))
(gfg::initialize-magick (cffi:null-pointer))
- (setf *the-thread-context* (make-instance 'thread-context))
(funcall start-fn)
(run-default-message-loop))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun May 7 17:21:43 2006
@@ -33,8 +33,9 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd")
-(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd")
+ (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd"))
;;;
;;; helper functions
More information about the Graphic-forms-cvs
mailing list