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