[graphic-forms-cvs] r164 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Jun 28 02:15:01 UTC 2006
Author: junrue
Date: Tue Jun 27 22:15:00 2006
New Revision: 164
Modified:
trunk/docs/manual/api.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
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/event.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
edit controls can now be created, minimally tested via layout-tester
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Tue Jun 27 22:15:00 2006
@@ -293,11 +293,14 @@
@item :auto-hscroll
Specifies that the @code{edit control} will scroll text content to the
right by 10 characters when the user types a character at the end
-of the line.
+of the line. For single-line @code{edit control}s, this style is set
+by the library.
@item :auto-vscroll
Specifies that the @code{edit control} will scroll text up by a page
when the user types @sc{enter} on the last line. This style keyword
is only meaningful when @code{:multi-line} is also specified.
+ at item :horizontal-scrollbar
+Specifies that a horizontal scrollbar should be displayed.
@item :mask-characters
Specifies that each character of text be masked by an echo character
instead of the one literally typed. The character can be changed via
@@ -319,6 +322,8 @@
@item :read-only
Specifies that the @code{edit control}'s contents cannot be modified by
the user.
+ at item :vertical-scrollbar
+Specifies that a vertical scrollbar should be displayed.
@item :want-return
Specifies that a carriage return be inserted when the user types
@sc{enter}. This style keyword only applies when the @code{:multi-line}
@@ -327,6 +332,9 @@
default button.
@end table
@end deffn
+ at deffn Initarg :text
+Supplies the initial text for the @code{edit control}.
+ at end deffn
@end deftp
@anchor{event-dispatcher}
@@ -987,8 +995,13 @@
Set the size and location of this object's children.
@end deffn
- at deffn GenericFunction location self
-Returns a @ref{point} object describing the coordinates of the
+ at anchor{line-count}
+ at deffn GenericFunction line-count self => integer
+Returns the total number of lines (e.g., of text) contained by @code{self}.
+ at end deffn
+
+ at deffn GenericFunction location self => @ref{point}
+Returns a point object describing the coordinates of the
top-left corner of the object in its parent's coordinate
system. @xref{parent}.
@end deffn
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Jun 27 22:15:00 2006
@@ -227,6 +227,7 @@
#:control
#:dialog
#:display
+ #:edit
#:event-dispatcher
#:event-source
#:file-dialog
@@ -414,6 +415,7 @@
#:layout-of
#:layout-p
#:left-margin-of
+ #:line-count
#:lines-visible-p
#:location
#:lock
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Jun 27 22:15:00 2006
@@ -34,10 +34,11 @@
(in-package #:graphic-forms.uitoolkit.tests)
(defconstant +btn-text-before+ "Push Me")
-(defconstant +btn-text-after+ "Again!")
-(defconstant +label-text+ "Label")
-(defconstant +margin-delta+ 4)
-(defconstant +spacing-delta+ 3)
+(defconstant +btn-text-after+ "Again!")
+(defconstant +edit-text+ "something to edit")
+(defconstant +label-text+ "Label")
+(defconstant +margin-delta+ 4)
+(defconstant +spacing-delta+ 3)
(defvar *widget-counter* 0)
@@ -99,7 +100,7 @@
(defun add-layout-tester-widget (widget-class subtype)
(let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*))
- (w nil))
+ (w nil))
(cond
((or (eql subtype :check-box)
(eql subtype :push-button)
@@ -112,6 +113,10 @@
:style (list subtype)))
(setf (toggle-fn be) (create-button-toggler be))
(setf (gfw:text w) (funcall (toggle-fn be))))
+ ((eql subtype :single-line-edit)
+ (setf w (make-instance widget-class
+ :parent *layout-tester-win*
+ :text (format nil "~d ~a" (id be) +edit-text+))))
((eql subtype :image-label)
;; NOTE: we are leaking a bitmap handle by not tracking the
;; image being created here
@@ -389,6 +394,8 @@
(pack-disp (make-instance 'pack-layout-dispatcher))
(add-btn-disp (make-instance 'add-child-dispatcher))
(add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box))
+ (add-edit-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:edit
+ :subtype :single-line-edit))
(add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button))
(add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button))
(add-tri-state-disp (make-instance 'add-child-dispatcher :subtype :tri-state))
@@ -411,14 +418,15 @@
:callback #'exit-layout-callback)))
(:item "&Children"
:submenu ((:item "Add"
- :submenu ((:item "Button" :dispatcher add-btn-disp)
- (:item "Checkbox" :dispatcher add-checkbox-disp)
+ :submenu ((:item "Button" :dispatcher add-btn-disp)
+ (:item "Checkbox" :dispatcher add-checkbox-disp)
+ (:item "Edit" :dispatcher add-edit-disp)
(:item "Label - Image" :dispatcher add-image-label-disp)
- (:item "Label - Text" :dispatcher add-text-label-disp)
- (:item "Panel" :dispatcher add-panel-disp)
- (:item "Radiobutton" :dispatcher add-radio-disp)
- (:item "Toggle" :dispatcher add-toggle-disp)
- (:item "Tri-State" :dispatcher add-tri-state-disp)))
+ (:item "Label - Text" :dispatcher add-text-label-disp)
+ (:item "Panel" :dispatcher add-panel-disp)
+ (:item "Radiobutton" :dispatcher add-radio-disp)
+ (:item "Toggle" :dispatcher add-toggle-disp)
+ (:item "Tri-State" :dispatcher add-tri-state-disp)))
(:item "Remove" :dispatcher rem-menu-disp
:submenu ((:item "")))
(:item "Visible" :dispatcher vis-menu-disp
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Tue Jun 27 22:15:00 2006
@@ -34,6 +34,7 @@
(in-package :graphic-forms.uitoolkit.system)
(defconstant +button-classname+ "button")
+(defconstant +edit-classname+ "edit")
(defconstant +static-classname+ "static")
(defconstant +ad-counterclockwise+ 1)
@@ -47,31 +48,31 @@
(defconstant +bi-png+ 5)
(defconstant +blt-blackness+ #x00000042)
-(defconstant +blt-notsrcerase+ #x001100a6)
+(defconstant +blt-notsrcerase+ #x001100A6)
(defconstant +blt-notsrccopy+ #x00330008)
(defconstant +blt-srcerase+ #x00440328)
(defconstant +blt-dstinvert+ #x00550009)
-(defconstant +blt-patinvert+ #x005a0049)
+(defconstant +blt-patinvert+ #x005A0049)
(defconstant +blt-srcinvert+ #x00660046)
-(defconstant +blt-srcand+ #x008800c6)
-(defconstant +blt-mergecopy+ #x00c000ca)
-(defconstant +blt-mergepaint+ #x00bb0226)
-(defconstant +blt-srccopy+ #x00cc0020)
-(defconstant +blt-srcpaint+ #x00ee0086)
-(defconstant +blt-patcopy+ #x00f00021)
-(defconstant +blt-patpaint+ #x00fb0a09)
-(defconstant +blt-whiteness+ #x00ff0062)
+(defconstant +blt-srcand+ #x008800C6)
+(defconstant +blt-mergecopy+ #x00C000CA)
+(defconstant +blt-mergepaint+ #x00BB0226)
+(defconstant +blt-srccopy+ #x00CC0020)
+(defconstant +blt-srcpaint+ #x00EE0086)
+(defconstant +blt-patcopy+ #x00F00021)
+(defconstant +blt-patpaint+ #x00FB0A09)
+(defconstant +blt-whiteness+ #x00FF0062)
(defconstant +blt-captureblt+ #x40000000)
(defconstant +blt-nomirrorbitmap+ #x80000000)
-(defconstant +bm-getcheck+ #x00f0)
-(defconstant +bm-setcheck+ #x00f1)
-(defconstant +bm-getstate+ #x00f2)
-(defconstant +bm-setstate+ #x00f3)
-(defconstant +bm-setstyle+ #x00f4)
-(defconstant +bm-click+ #x00f5)
-(defconstant +bm-getimage+ #x00f6)
-(defconstant +bm-setimage+ #x00f7)
+(defconstant +bm-getcheck+ #x00F0)
+(defconstant +bm-setcheck+ #x00F1)
+(defconstant +bm-getstate+ #x00F2)
+(defconstant +bm-setstate+ #x00F3)
+(defconstant +bm-setstyle+ #x00F4)
+(defconstant +bm-click+ #x00F5)
+(defconstant +bm-getimage+ #x00F6)
+(defconstant +bm-setimage+ #x00F7)
(defconstant +bs-solid+ 0)
(defconstant +bs-null+ 1)
@@ -139,7 +140,7 @@
(defconstant +cderr-memallocfailure+ #x0009)
(defconstant +cderr-memlockfailure+ #x000a)
(defconstant +cderr-nohook+ #x000b)
-(defconstant +cderr-registermsgfail+ #x000c)
+(defconstant +cderr-registermsgfail+ #x000C)
(defconstant +cferr-choosefontcodes+ #x2000)
(defconstant +cferr-nofonts+ #x2001)
@@ -230,6 +231,46 @@
(defconstant +dt-hideprefix+ #x00100000)
(defconstant +dt-prefixonly+ #x00200000)
+(defconstant +em-getsel+ #x00B0)
+(defconstant +em-setsel+ #x00B1)
+(defconstant +em-getrect+ #x00B2)
+(defconstant +em-setrect+ #x00B3)
+(defconstant +em-setrectnp+ #x00B4)
+(defconstant +em-scroll+ #x00B5)
+(defconstant +em-linescroll+ #x00B6)
+(defconstant +em-scrollcaret+ #x00B7)
+(defconstant +em-getmodify+ #x00B8)
+(defconstant +em-setmodify+ #x00B9)
+(defconstant +em-getlinecount+ #x00BA)
+(defconstant +em-lineindex+ #x00BB)
+(defconstant +em-sethandle+ #x00BC)
+(defconstant +em-gethandle+ #x00BD)
+(defconstant +em-getthumb+ #x00BE)
+(defconstant +em-linelength+ #x00C1)
+(defconstant +em-replacesel+ #x00C2)
+(defconstant +em-getline+ #x00C4)
+(defconstant +em-limittext+ #x00C5)
+(defconstant +em-canundo+ #x00C6)
+(defconstant +em-undo+ #x00C7)
+(defconstant +em-fmtlines+ #x00C8)
+(defconstant +em-linefromchar+ #x00C9)
+(defconstant +em-settabstops+ #x00CB)
+(defconstant +em-setpasswordchar+ #x00CC)
+(defconstant +em-emptyundobuffer+ #x00CD)
+(defconstant +em-getfirstvisibleline+ #x00CE)
+(defconstant +em-setreadonly+ #x00CF)
+(defconstant +em-setwordbreakproc+ #x00D0)
+(defconstant +em-getwordbreakproc+ #x00D1)
+(defconstant +em-getpasswordchar+ #x00D2)
+(defconstant +em-setmargins+ #x00D3)
+(defconstant +em-getmargins+ #x00D4)
+(defconstant +em-setlimittext+ #x00C5)
+(defconstant +em-getlimittext+ #x00D5)
+(defconstant +em-posfromchar+ #x00D6)
+(defconstant +em-charfrompos+ #x00D7)
+(defconstant +em-setimestatus+ #x00D8)
+(defconstant +em-getimestatus+ #x00D9)
+
(defconstant +es-left+ #x0000)
(defconstant +es-center+ #x0001)
(defconstant +es-right+ #x0002)
@@ -545,8 +586,8 @@
(defconstant +pderr-nodefaultprn+ #x1008)
(defconstant +pderr-dndmmismatch+ #x1009)
(defconstant +pderr-createicfailure+ #x100a)
-(defconstant +pderr-printernotfound+ #x100b)
-(defconstant +pderr-defaultdifferent+ #x100c)
+(defconstant +pderr-printernotfound+ #x100B)
+(defconstant +pderr-defaultdifferent+ #x100C)
(defconstant +qs-key+ #x0001)
(defconstant +qs-mousemove+ #x0002)
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Tue Jun 27 22:15:00 2006
@@ -40,10 +40,10 @@
;;; methods
;;;
-(defmethod compute-style-flags ((btn button) &rest extra-data)
+(defmethod compute-style-flags ((self button) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags +default-child-style+)
- (style (style-of btn)))
+ (style (style-of self)))
(loop for sym in style
do (cond
;; primary button styles
@@ -64,27 +64,26 @@
(logior std-flags gfs::+bs-pushbutton+))
(values std-flags 0)))
-(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys)
+(defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys)
+ (initialize-comctl-classes gfs::+icc-standard-classes+)
(multiple-value-bind (std-style ex-style)
- (compute-style-flags btn)
+ (compute-style-flags self)
(let ((hwnd (create-window gfs::+button-classname+
(or text " ")
(gfs:handle parent)
std-style
ex-style
(cond
- ((find :default-button (style-of btn))
+ ((find :default-button (style-of self))
gfs::+idok+)
- ((find :cancel-button (style-of btn))
+ ((find :cancel-button (style-of self))
gfs::+idcancel+)
(t
(increment-widget-id (thread-context)))))))
- (if (not hwnd)
- (error 'gfs:win32-error :detail "create-window failed"))
(unless (zerop (logand std-style gfs::+bs-defpushbutton+))
(gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0))
- (setf (slot-value btn 'gfs:handle) hwnd)))
- (init-control btn))
+ (setf (slot-value self 'gfs:handle) hwnd)))
+ (init-control self))
(defmethod preferred-size ((self button) width-hint height-hint)
(let ((text-size (widget-text-size self gfs::+dt-singleline+))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Tue Jun 27 22:15:00 2006
@@ -43,11 +43,7 @@
(put-widget (thread-context) ctrl)
(let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
(unless (gfs:null-handle-p hfont)
- (unless (zerop (gfs::send-message hwnd
- gfs::+wm-setfont+
- (cffi:pointer-address hfont)
- 0))
- (error 'gfs:win32-error :detail "send-message failed"))))))
+ (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)))))
;;;
;;; methods
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jun 27 22:15:00 2006
@@ -33,30 +33,71 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defconstant +horizontal-edit-text-margin+ 2)
+(defconstant +vertical-edit-text-margin+ 2)
+
;;;
;;; methods
;;;
(defmethod compute-style-flags ((self edit) &rest extra-data)
(declare (ignore extra-data))
- (let ((border-flag (if (find :no-border (style-of self)) 0 gfs::+ws-border+)))
- (values (loop for sym in (style-of self)
- for std-flags = (logior +default-child-style+ border-flag)
- then (logior std-flags
- (ecase sym
- ;; primary edit styles
- ;;
- (:multi-line (logior +default-child-style+
- gfs::+es-multiline+
- border-flag))
-
- ;; styles that can be combined
- ;;
- (:auto-hscroll gfs::+es-autohscroll+)
- (:auto-vscroll gfs::+es-autovscroll+)
- (:mask-characters gfs::+es-password+)
- (:no-hide-selection gfs::+es-nohidesel+)
- (:read-only gfs::+es-readonly+)
- (:want-return gfs::+es-wantreturn+)))
- finally (return std-flags))
- 0)))
+ (let ((std-flags +default-child-style+)
+ (style (style-of self)))
+ (loop for sym in style
+ do (ecase sym
+ ;; primary edit styles
+ ;;
+ (:multi-line (setf std-flags (logior +default-child-style+
+ gfs::+es-multiline+)))
+ ;; styles that can be combined
+ ;;
+ (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+)))
+ (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+)))
+ (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+)))
+ (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+)))
+ (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+)))
+ (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+)))))
+ (if (not (find :multi-line style))
+ (setf std-flags (logior std-flags gfs::+es-autohscroll+)))
+ (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+))))
+
+(defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys)
+ (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+
+ (or text "")
+ (gfs:handle parent)
+ std-style
+ ex-style
+ (increment-widget-id (thread-context)))))
+ (setf (slot-value self 'gfs:handle) hwnd)))
+ (init-control self))
+
+(defmethod line-count ((self edit))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0))
+
+(defmethod preferred-size ((self edit) width-hint height-hint)
+ (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+)))
+ (size (gfs:make-size))
+ (b-width (* (border-width self) 2)))
+ (if (>= width-hint 0)
+ (setf (gfs:size-width size) width-hint)
+ (setf (gfs:size-width size) (+ b-width
+ (gfs:size-width text-size)
+ (* +horizontal-edit-text-margin+ 2))))
+ (if (>= height-hint 0)
+ (setf (gfs:size-height size) height-hint)
+ (setf (gfs:size-height size) (+ b-width
+ (* (gfs:size-height text-size) (line-count self))
+ (* +vertical-edit-text-margin+ 2))))
+ size))
+
+(defmethod text ((self edit))
+ (get-widget-text self))
+
+(defmethod (setf text) (str (self edit))
+ (set-widget-text self str))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Tue Jun 27 22:15:00 2006
@@ -115,7 +115,7 @@
(if (zerop (gfs::set-window-long hwnd
gfs::+gwlp-wndproc+
(cffi:pointer-address
- (cffi:get-callback 'subclassing_wndproc))))
+ (cffi:get-callback 'subclassing_wndproc))))
(error 'gfs:win32-error :detail "set-window-long failed")))
;;;
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Tue Jun 27 22:15:00 2006
@@ -152,6 +152,7 @@
(cffi:pointer-address (gfs:handle image)))))
(defmethod initialize-instance :after ((label 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+
@@ -160,8 +161,6 @@
(logior std-style)
ex-style
(increment-widget-id (thread-context)))))
- (if (not hwnd)
- (error 'gfs:win32-error :detail "create-window failed"))
(setf (slot-value label 'gfs:handle) hwnd)
(if image
(setf (image label) image))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Jun 27 22:15:00 2006
@@ -99,8 +99,6 @@
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)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jun 27 22:15:00 2006
@@ -189,6 +189,9 @@
(defgeneric layout (self)
(:documentation "Set the size and location of this object's children."))
+(defgeneric line-count (self)
+ (:documentation "Returns the total number of lines (e.g., of text)."))
+
(defgeneric lines-visible-p (self)
(:documentation "Returns T if the object's lines are visible; nil otherwise."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jun 27 22:15:00 2006
@@ -78,24 +78,34 @@
(unless (zerop count)
(gfw:clear-span w (gfs:make-span :start 0 :end (1- count))))))
+(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))
+ (warn 'gfs:toolkit-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)
- (gfs::create-window
- ex-style
- cname-ptr
- title-ptr
- (if child-id (logior std-style gfs::+ws-tabstop+) std-style)
- gfs::+cw-usedefault+
- gfs::+cw-usedefault+
- gfs::+cw-usedefault+
- gfs::+cw-usedefault+
- parent-hwnd
- (if (zerop (logand gfs::+ws-child+ std-style))
- (cffi:null-pointer)
- (cffi:make-pointer (or child-id (increment-widget-id (thread-context)))))
- (cffi:null-pointer)
- 0))))
+ (let ((hwnd (gfs::create-window ex-style
+ cname-ptr
+ title-ptr
+ (if child-id (logior std-style gfs::+ws-tabstop+) std-style)
+ gfs::+cw-usedefault+
+ gfs::+cw-usedefault+
+ gfs::+cw-usedefault+
+ gfs::+cw-usedefault+
+ parent-hwnd
+ (if (zerop (logand gfs::+ws-child+ std-style))
+ (cffi:null-pointer)
+ (cffi:make-pointer (or child-id (increment-widget-id (thread-context)))))
+ (cffi:null-pointer)
+ 0)))
+ (if (gfs:null-handle-p hwnd)
+ (error 'gfs:win32-error :detail "create-window failed"))
+ hwnd))))
(defun get-widget-text (w)
(if (gfs:disposed-p w)
More information about the Graphic-forms-cvs
mailing list