[graphic-forms-cvs] r276 - in trunk/src/uitoolkit: system widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Sep 29 16:43:18 UTC 2006
Author: junrue
Date: Fri Sep 29 12:43:16 2006
New Revision: 276
Modified:
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/edit.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/list-box.lisp
trunk/src/uitoolkit/widgets/slider.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
define-control-class macro now includes class allocated slot for win32 window classname
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Fri Sep 29 12:43:16 2006
@@ -34,16 +34,6 @@
(in-package :graphic-forms.uitoolkit.system)
;;;
-;;; control class names
-;;;
-(defparameter *button-classname* "button")
-(defparameter *edit-classname* "edit")
-(defparameter *listbox-classname* "listbox")
-(defparameter *scrollbar-classname* "scrollbar")
-(defparameter *static-classname* "static")
-(defparameter *trackbar-classname* "msctls_trackbar32")
-
-;;;
;;; registered message names
;;;
(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify")
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 29 12:43:16 2006
@@ -76,7 +76,7 @@
(initialize-comctl-classes gfs::+icc-standard-classes+)
(multiple-value-bind (std-style ex-style)
(compute-style-flags self)
- (let ((hwnd (create-window gfs::*button-classname*
+ (let ((hwnd (create-window (system-classname-of self)
(or text " ")
(gfs:handle parent)
std-style
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Fri Sep 29 12:43:16 2006
@@ -37,6 +37,16 @@
;;; helper functions
;;;
+(defun initialize-comctl-classes (icc-flags)
+ (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex)
+ (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex)
+ (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex)
+ gfs::icc icc-flags))
+ (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0))
+ ;; returns false when called on SBCL with ICC_STANDARD_CLASSES, so
+ ;; this warning gets triggered a lot; need to investigate further
+ (warn 'gfs:win32-warning :detail "init-common-controls failed"))))
+
(defun init-control (ctrl)
(let ((hwnd (gfs:handle ctrl)))
(subclass-wndproc hwnd)
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 29 12:43:16 2006
@@ -95,7 +95,7 @@
(initialize-comctl-classes gfs::+icc-standard-classes+)
(multiple-value-bind (std-style ex-style)
(compute-style-flags self)
- (let ((hwnd (create-window gfs::*edit-classname*
+ (let ((hwnd (create-window (system-classname-of self)
(or text "")
(gfs:handle parent)
std-style
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 29 12:43:16 2006
@@ -147,20 +147,20 @@
gfs::+image-bitmap+
(cffi:pointer-address (gfs:handle image)))))
-(defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys)
+(defmethod initialize-instance :after ((self label) &key image parent separator text &allow-other-keys)
(initialize-comctl-classes gfs::+icc-standard-classes+)
(multiple-value-bind (std-style ex-style)
- (compute-style-flags label image separator text)
- (let ((hwnd (create-window gfs::*static-classname*
+ (compute-style-flags self image separator text)
+ (let ((hwnd (create-window (system-classname-of self)
(or text " ")
(gfs:handle parent)
(logior std-style)
ex-style
(increment-widget-id (thread-context)))))
- (setf (slot-value label 'gfs:handle) hwnd)
+ (setf (slot-value self 'gfs:handle) hwnd)
(if image
- (setf (image label) image))))
- (init-control label))
+ (setf (image self) image))))
+ (init-control self))
(defmethod preferred-size ((self label) width-hint height-hint)
(let ((bits (get-native-style self))
Modified: trunk/src/uitoolkit/widgets/list-box.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-box.lisp (original)
+++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 29 12:43:16 2006
@@ -223,7 +223,7 @@
(initialize-comctl-classes gfs::+icc-standard-classes+)
(multiple-value-bind (std-style ex-style)
(compute-style-flags self)
- (let ((hwnd (create-window gfs::*listbox-classname*
+ (let ((hwnd (create-window (system-classname-of self)
""
(gfs:handle parent)
std-style
Modified: trunk/src/uitoolkit/widgets/slider.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/slider.lisp (original)
+++ trunk/src/uitoolkit/widgets/slider.lisp Fri Sep 29 12:43:16 2006
@@ -96,3 +96,16 @@
(:ticks-before (setf std-flags (sl-ticks-before-flags std-flags)))
(:tooltip (setf std-flags (sl-tooltip-flags std-flags)))))
(values std-flags 0)))
+
+(defmethod initialize-instance :after ((self slider) &key parent &allow-other-keys)
+ (initialize-comctl-classes gfs::+icc-win95-classes+)
+ (multiple-value-bind (std-style ex-style)
+ (compute-style-flags self)
+ (let ((hwnd (create-window (system-classname-of self)
+ ""
+ (gfs:handle parent)
+ std-style
+ ex-style
+ (increment-widget-id (thread-context)))))
+ (setf (slot-value self 'gfs:handle) hwnd)
+ (init-control self))))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 29 12:43:16 2006
@@ -174,40 +174,52 @@
:initform nil))
(:documentation "The base class for widgets having pre-defined native behavior."))
-(defmacro define-control-class (classname callback-event-name &optional docstring mixins)
+(defmacro define-control-class (classname system-classname callback-event-name &optional docstring mixins)
`(defclass ,classname `,(control , at mixins)
((,(intern "CALLBACK-EVENT-NAME")
:accessor ,(intern "CALLBACK-EVENT-NAME-OF")
:initform ,callback-event-name
+ :allocation :class)
+ (,(intern "SYSTEM-CLASSNAME")
+ :reader ,(intern "SYSTEM-CLASSNAME-OF")
+ :initform ,system-classname
:allocation :class))
,(if (typep docstring 'string) `(:documentation ,docstring) `(:documentation ""))))
(define-control-class
button
+ "button"
'event-select
"This class represents selectable controls that issue notifications when clicked.")
(define-control-class
edit
+ "edit"
'event-modify
"This class represents a control in which the user may enter and edit text.")
-(defclass label (control) ()
- (:documentation "This class represents non-selectable controls that display a string or image."))
+(define-control-class
+ label
+ "static"
+ 'event-select
+ "This class represents non-selectable controls that display a string or image.")
(define-control-class
list-box
+ "listbox"
'event-select
"The list-box class represents a listbox control."
(item-manager))
(define-control-class
scrollbar
+ "scrollbar"
'event-select
"This class represents an individual scrollbar control.")
(define-control-class
slider
+ "msctls_trackbar32"
'event-select
"This class represents a slider (or trackbar) control.")
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 29 12:43:16 2006
@@ -107,16 +107,6 @@
(defun shutdown (exit-code)
(gfs::post-quit-message exit-code))
-(defun initialize-comctl-classes (icc-flags)
- (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex)
- (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex)
- (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex)
- gfs::icc icc-flags))
- (if (zerop (gfs::init-common-controls ic-ptr))
- ;; returns false when called on SBCL with ICC_STANDARD_CLASSES, so
- ;; this warning gets triggered a lot; need to investigate further
- (warn 'gfs:win32-warning :detail "init-common-controls failed"))))
-
(defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id)
(cffi:with-foreign-string (cname-ptr class-name)
(cffi:with-foreign-string (title-ptr title)
More information about the Graphic-forms-cvs
mailing list