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 ,@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)