[graphic-forms-cvs] r204 - in trunk: . src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Aug 10 06:08:06 UTC 2006
Author: junrue
Date: Thu Aug 10 02:08:05 2006
New Revision: 204
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/demos/unblocked/scoreboard-panel.lisp
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/system/clib.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/dialog.lisp
trunk/src/uitoolkit/widgets/edit.lisp
trunk/src/uitoolkit/widgets/event-source.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/panel.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
initial phase of SBCL port completed
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 02:08:05 2006
@@ -51,6 +51,7 @@
:depends-on ("packages")
:components
((:module "system"
+ :serial t
:components
((:file "system-constants")
(:file "system-classes")
@@ -74,8 +75,10 @@
(:file "graphics-generics")
(:file "color")
(:file "palette")
- (:file "image-data")
- (:file "image")
+ (:file "image-data"
+ :depends-on ("graphics-classes"))
+ (:file "image"
+ :depends-on ("graphics-classes"))
(:file "icon-bundle"
:depends-on ("graphics-constants" "image"))
(:file "font-data")
@@ -85,10 +88,12 @@
:components
((:file "graphics-plugin-packages")
#-skip-default-plugin (:module "default"
+ :serial t
:components
((:file "file-formats")
(:file "default-data-plugin")))
#+load-imagemagick-plugin (:module "imagemagick"
+ :serial t
:components
((:file "magick-core-types")
(:file "magick-core-api")
@@ -96,6 +101,7 @@
:depends-on ("magick-core-types" "magick-core-api"))))))))
(:module "widgets"
:depends-on ("graphics")
+ :serial t
:components
((:file "widget-constants")
(:file "widget-classes")
Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/scoreboard-panel.lisp (original)
+++ trunk/src/demos/unblocked/scoreboard-panel.lisp Thu Aug 10 02:08:05 2006
@@ -33,9 +33,9 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defconstant +level-label+ "Level:")
-(defconstant +points-needed-label+ "Points Needed:")
-(defconstant +score-label+ "Score:")
+(defparameter *level-label* "Level:")
+(defparameter *points-needed-label* "Points Needed:")
+(defparameter *score-label* "Score:")
(defconstant +scoreboard-text-margin+ 2)
@@ -73,7 +73,7 @@
(buffer-size (gfs:make-size)))
(unwind-protect
(progn
- (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+)
+ (setf (gfs:size-width buffer-size) (* (+ (length *points-needed-label*)
2 ; space between label and value
9) ; number of value characters
(gfg:average-char-width metrics)))
@@ -112,9 +112,9 @@
(unwind-protect
(progn
(clear-buffer self gc)
- (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score))
- (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level))
- (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed)))
+ (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score))
+ (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level))
+ (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed)))
(gfs:dispose gc))))
(defclass scoreboard-panel (gfw:panel) ())
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu Aug 10 02:08:05 2006
@@ -233,6 +233,10 @@
(defpackage #:graphic-forms.uitoolkit.widgets
(:nicknames #:gfw)
(:use #:common-lisp)
+#+sbcl
+ (:import-from :sb-mop :ensure-generic-function)
+#-sbcl
+ (:import-from :clos :ensure-generic-function)
(:export
;; classes and structs
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Aug 10 02:08:05 2006
@@ -33,12 +33,13 @@
(in-package #:graphic-forms.uitoolkit.tests)
-(defconstant +btn-text-before+ "Push Me")
-(defconstant +btn-text-after+ "Again!")
-(defconstant +edit-text+ "something to edit")
-(defconstant +label-text+ "Label")
-(defconstant +margin-delta+ 4)
-(defconstant +spacing-delta+ 3)
+(defparameter *btn-text-before* "Push Me")
+(defparameter *btn-text-after* "Again!")
+(defparameter *edit-text* "something to edit")
+(defparameter *label-text* "Label")
+
+(defconstant +margin-delta+ 4)
+(defconstant +spacing-delta+ 3)
(defvar *widget-counter* 0)
@@ -93,10 +94,10 @@
(if (null flag)
(progn
(setf flag t)
- (format nil "~d ~a" (id be) +btn-text-before+))
+ (format nil "~d ~a" (id be) *btn-text-before*))
(progn
(setf flag nil)
- (format nil "~d ~a" (id be) +btn-text-after+))))))
+ (format nil "~d ~a" (id be) *btn-text-after*))))))
(defun add-layout-tester-widget (widget-class subtype)
(let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*))
@@ -119,7 +120,7 @@
((eql subtype :single-line-edit)
(setf w (make-instance widget-class
:parent *layout-tester-win*
- :text (format nil "~d ~a" (id be) +edit-text+))))
+ :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
@@ -135,7 +136,7 @@
:parent *layout-tester-win*
:dispatcher be
:style '(:sunken)))
- (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))
+ (setf (gfw:text w) (format nil "~d ~a" (id be) *label-text*)))
(t
(setf w (make-instance widget-class
:parent *layout-tester-win*
Modified: trunk/src/uitoolkit/system/clib.lisp
==============================================================================
--- trunk/src/uitoolkit/system/clib.lisp (original)
+++ trunk/src/uitoolkit/system/clib.lisp Thu Aug 10 02:08:05 2006
@@ -36,6 +36,8 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cffi))
+(load-foreign-library "msvcrt.dll")
+
(defcfun
("strncpy" strncpy)
:pointer
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Thu Aug 10 02:08:05 2006
@@ -167,16 +167,6 @@
(hdc HANDLE))
(defcfun
- ("DrawTextExA" draw-text-ex)
- INT
- (hdc HANDLE)
- (text :string)
- (count INT)
- (rect LPTR)
- (format UINT)
- (params LPTR))
-
-(defcfun
("Ellipse" ellipse)
BOOL
(hdc HANDLE)
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Thu Aug 10 02:08:05 2006
@@ -36,20 +36,20 @@
;;;
;;; control class names
;;;
-(defconstant +button-classname+ "button")
-(defconstant +edit-classname+ "edit")
-(defconstant +static-classname+ "static")
+(defparameter *button-classname* "button")
+(defparameter *edit-classname* "edit")
+(defparameter *static-classname* "static")
;;;
;;; registered message names
;;;
-(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify")
-(defconstant +sharevistringa+ "commdlg_ShareViolation")
-(defconstant +fileokstringa+ "commdlg_FileNameOK")
-(defconstant +colorokstringa+ "commdlg_ColorOK")
-(defconstant +setrgbstringa+ "commdlg_SetRGBColor")
-(defconstant +helpmsgstringa+ "commdlg_help")
-(defconstant +findmsgstringa+ "commdlg_FindReplace")
+(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify")
+(defparameter *sharevistringa* "commdlg_ShareViolation")
+(defparameter *fileokstringa* "commdlg_FileNameOK")
+(defparameter *colorokstringa* "commdlg_ColorOK")
+(defparameter *setrgbstringa* "commdlg_SetRGBColor")
+(defparameter *helpmsgstringa* "commdlg_help")
+(defparameter *findmsgstringa* "commdlg_FindReplace")
(defconstant +ad-counterclockwise+ 1)
(defconstant +ad-clockwise+ 2)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 02:08:05 2006
@@ -154,6 +154,16 @@
(hwnd HANDLE))
(defcfun
+ ("DrawTextExA" draw-text-ex)
+ INT
+ (hdc HANDLE)
+ (text :string)
+ (count INT)
+ (rect LPTR)
+ (format UINT)
+ (params LPTR))
+
+(defcfun
("EnableMenuItem" enable-menu-item)
BOOL
(hmenu HANDLE)
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Thu Aug 10 02:08:05 2006
@@ -79,7 +79,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 gfs::*button-classname*
(or text " ")
(gfs:handle parent)
std-style
Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Aug 10 02:08:05 2006
@@ -33,17 +33,18 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +default-dialog-title+ " ")
-(defconstant +dlgwindowextra+ 48)
+(defparameter *default-dialog-title* " ")
-(defvar *disabled-top-levels* nil)
+(defconstant +dlgwindowextra+ 48)
+
+(defvar *disabled-top-levels* nil)
;;;
;;; helper functions
;;;
(defun register-dialog-class ()
- (register-window-class +dialog-classname+
+ (register-window-class *dialog-classname*
(cffi:get-callback 'uit_widgets_wndproc)
(logior gfs::+cs-dblclks+
gfs::+cs-savebits+
@@ -167,7 +168,7 @@
(if (gfs:disposed-p owner)
(error 'gfs:disposed-error)))
(if (null text)
- (setf text +default-dialog-title+))
+ (setf text *default-dialog-title*))
;; NOTE: do not allow apps to specify the desktop window as the
;; owner of the dialog; it would cause the desktop to become
;; disabled.
@@ -179,7 +180,7 @@
;; walk up the ancestors until one is found. Only top level hwnds can
;; be owners.
;;
- (init-window self +dialog-classname+ #'register-dialog-class owner text))
+ (init-window self *dialog-classname* #'register-dialog-class owner text))
(defmethod show ((self dialog) flag)
(let ((app-modal (find :application-modal (style-of self)))
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Thu Aug 10 02:08:05 2006
@@ -97,7 +97,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 gfs::*edit-classname*
(or text "")
(gfs:handle parent)
std-style
Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp Thu Aug 10 02:08:05 2006
@@ -33,10 +33,10 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source))
- (gfw:event-arm . (gfw:event-source))
- (gfw:event-modify . (gfw:event-source))
- (gfw:event-select . (gfw:event-source))))
+(defparameter *callback-info* '((gfw:event-activate . (gfw:event-source))
+ (gfw:event-arm . (gfw:event-source))
+ (gfw:event-modify . (gfw:event-source))
+ (gfw:event-select . (gfw:event-source))))
(defun make-specializer-list (disp-class arg-info)
(let ((tmp (mapcar #'find-class arg-info)))
@@ -45,12 +45,12 @@
(defun define-dispatcher-for-callbacks (callbacks)
(let ((*print-gensym* nil)
- (class (clos:ensure-class (gentemp "EDCLASS" :gfgen)
+ (class (c2mop:ensure-class (gentemp "EDCLASS" :gfgen)
:direct-superclasses '(event-dispatcher))))
(loop for pair in callbacks
do (let* ((method-sym (car pair))
(fn (cdr pair))
- (arg-info (cdr (assoc method-sym +callback-info+)))
+ (arg-info (cdr (assoc method-sym *callback-info*)))
(args nil))
`(unless (or (symbolp ,fn) (functionp ,fn))
(error 'gfs:toolkit-error
@@ -61,7 +61,7 @@
method-sym)))
(dotimes (i (1+ (length arg-info)))
(push (gentemp "ARG" :gfgen) args))
- (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args)
+ (c2mop:ensure-method (ensure-generic-function method-sym :lambda-list args)
`(lambda ,args (funcall ,fn , at args))
:specializers (make-specializer-list class arg-info))))
class))
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Thu Aug 10 02:08:05 2006
@@ -152,7 +152,7 @@
(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+
+ (let ((hwnd (create-window gfs::*static-classname*
(or text " ")
(gfs:handle parent)
(logior std-style)
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Thu Aug 10 02:08:05 2006
@@ -41,7 +41,7 @@
(declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items
(let ((info-mask (logior gfs::+miim-id+
(if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+)
- (if hchildmenu gfs::+miim-submenu+)))
+ (if hchildmenu gfs::+miim-submenu+ 0)))
(info-type (if label 0 gfs::+mft-separator+))
(info-state (logior (if checked gfs::+mfs-checked+ 0)
(if disabled gfs::+mfs-disabled+ 0))))
Modified: trunk/src/uitoolkit/widgets/panel.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/panel.lisp (original)
+++ trunk/src/uitoolkit/widgets/panel.lisp Thu Aug 10 02:08:05 2006
@@ -33,14 +33,14 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +panel-window-classname+ "GraphicFormsPanel")
+(defparameter *panel-window-classname* "GraphicFormsPanel")
;;;
;;; helper functions
;;;
(defun register-panel-window-class ()
- (register-window-class +panel-window-classname+
+ (register-window-class *panel-window-classname*
(cffi:get-callback 'uit_widgets_wndproc)
gfs::+cs-dblclks+
-1))
@@ -70,4 +70,4 @@
(error 'gfs:toolkit-error :detail "parent is required for panel"))
(if (gfs:disposed-p parent)
(error 'gfs:disposed-error))
- (init-window self +panel-window-classname+ #'register-panel-window-class parent ""))
+ (init-window self *panel-window-classname* #'register-panel-window-class parent ""))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Aug 10 02:08:05 2006
@@ -59,35 +59,42 @@
;; TODO: change this when CLISP acquires MT support
;;
-#+clisp (defvar *the-thread-context* nil)
+;; TODO: change this once we understand SBCL MT support
+;;
+#+(or clisp sbcl)
+(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)
- (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))
+#+(or clisp sbcl)
+(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*)
+
+#+(or clisp sbcl)
+(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)
+ (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)
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Aug 10 02:08:05 2006
@@ -33,20 +33,20 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +default-window-title+ "New Window")
+(defparameter *default-window-title* "New Window")
;;;
;;; helper functions
;;;
(defun register-toplevel-erasebkgnd-window-class ()
- (register-window-class +toplevel-erasebkgnd-window-classname+
+ (register-window-class *toplevel-erasebkgnd-window-classname*
(cffi:get-callback 'uit_widgets_wndproc)
gfs::+cs-dblclks+
gfs::+color-appworkspace+))
(defun register-toplevel-noerasebkgnd-window-class ()
- (register-window-class +toplevel-noerasebkgnd-window-classname+
+ (register-window-class *toplevel-noerasebkgnd-window-classname*
(cffi:get-callback 'uit_widgets_wndproc)
gfs::+cs-dblclks+
-1))
@@ -138,11 +138,11 @@
(if (gfs:disposed-p owner)
(error 'gfs:disposed-error)))
(if (null text)
- (setf text +default-window-title+))
- (let ((classname +toplevel-noerasebkgnd-window-classname+)
+ (setf text *default-window-title*))
+ (let ((classname *toplevel-noerasebkgnd-window-classname*)
(register-func #'register-toplevel-noerasebkgnd-window-class))
(when (find :workspace (style-of win))
- (setf classname +toplevel-erasebkgnd-window-classname+)
+ (setf classname *toplevel-erasebkgnd-window-classname*)
(setf register-func #'register-toplevel-erasebkgnd-window-class))
(init-window win classname register-func owner text)))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Aug 10 02:08:05 2006
@@ -79,20 +79,22 @@
(translate-and-dispatch msg-ptr)
nil)))
-#+clisp (defun startup (thread-name start-fn)
- (declare (ignore thread-name))
- (funcall start-fn)
- (message-loop #'default-message-filter))
-
-#+lispworks (defun startup (thread-name start-fn)
- (hcl:add-special-free-action 'gfs::native-object-special-action)
- (when (null (mp:list-all-processes))
- (mp:initialize-multiprocessing))
- (mp:process-run-function thread-name
- nil
- (lambda ()
- (funcall start-fn)
- (message-loop #'default-message-filter))))
+#+(or clisp sbcl)
+(defun startup (thread-name start-fn)
+ (declare (ignore thread-name))
+ (funcall start-fn)
+ (message-loop #'default-message-filter))
+
+#+lispworks
+(defun startup (thread-name start-fn)
+ (hcl:add-special-free-action 'gfs::native-object-special-action)
+ (if (null (mp:list-all-processes))
+ (mp:initialize-multiprocessing))
+ (mp:process-run-function thread-name
+ nil
+ (lambda ()
+ (funcall start-fn)
+ (message-loop #'default-message-filter))))
(defun shutdown (exit-code)
(gfs::post-quit-message exit-code))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 02:08:05 2006
@@ -33,10 +33,9 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +dialog-classname+ "GraphicFormsDialog")
- (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd")
- (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd"))
+(defparameter *dialog-classname* "GraphicFormsDialog")
+(defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd")
+(defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd")
;;;
;;; helper functions
@@ -145,7 +144,7 @@
(color nil))
(cffi:with-foreign-pointer-as-string (str-ptr 64)
(gfs::get-class-name hwnd str-ptr 64)
- (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+)
+ (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*)
(setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+)))
(setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+)))))
color))
More information about the Graphic-forms-cvs
mailing list