[graphic-forms-cvs] r390 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sun Nov  5 16:06:36 2006
New Revision: 390

Modified:
   trunk/config.lisp
   trunk/src/uitoolkit/system/system-utils.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/tests.lisp
Log:
more fixes for loading the system; minor cleanup in message-loop function; added a couple debug functions

Modified: trunk/config.lisp
==============================================================================
--- trunk/config.lisp	(original)
+++ trunk/config.lisp	Sun Nov  5 16:06:36 2006
@@ -43,6 +43,7 @@
 (defvar *closer-mop-dir*      "closer-mop/")
 (defvar *lw-compat-dir*       "lw-compat/")
 (defvar *gf-dir*              "graphic-forms/")
+(defvar *gf-tests-dir*        "graphic-forms/src/tests/uitoolkit/")
 (defvar *binary-data-dir*     "src/external-libraries/practicals-1.0.3/Chapter08/")
 (defvar *macro-utilities-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")
 (defvar *textedit-dir*        "src/demos/textedit/")

Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp	(original)
+++ trunk/src/uitoolkit/system/system-utils.lisp	Sun Nov  5 16:06:36 2006
@@ -37,6 +37,14 @@
 ;;; convenience functions
 ;;;
 
+(defun debug-format (str &rest args)
+  (apply #'format *trace-output* str args)
+  (finish-output))
+
+(defun debug-print (thing)
+  (print thing *trace-output*)
+  (finish-output))
+
 (defun recreate-array (array)
   (make-array (array-dimensions array)
               :element-type (array-element-type array)

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Nov  5 16:06:36 2006
@@ -71,13 +71,7 @@
   (cffi:with-foreign-object (msg-ptr 'gfs::msg)
     (loop
       (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)))
-        (cffi:with-foreign-slots ((gfs::hwnd
-                                   gfs::message
-                                   gfs::wparam
-                                   gfs::lparam
-                                   gfs::time
-                                   gfs::pnt)
-                                  msg-ptr gfs::msg)
+        (cffi:with-foreign-slots ((gfs::message gfs::wparam) msg-ptr gfs::msg)
           (when (funcall msg-filter gm msg-ptr)
             (return-from message-loop gfs::wparam)))))))
 

Modified: trunk/tests.lisp
==============================================================================
--- trunk/tests.lisp	(original)
+++ trunk/tests.lisp	Sun Nov  5 16:06:36 2006
@@ -34,14 +34,14 @@
 (in-package #:graphic-forms-system)
 
 (defun load-tests ()
-  (let ((tests-dir (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/")))
-    (setf *default-pathname-defaults* (parse-namestring tests-dir))
-    (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*textedit-dir*))
-    (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* gfsys::*unblocked-dir*))
+    (setf *gf-tests-dir* (concatenate 'string gfsys::*gf-dir* "src/tests/uitoolkit/"))
+    (setf *textedit-dir* (concatenate 'string gfsys::*gf-dir* "src/demos/textedit/"))
+    (setf *unblocked-dir* (concatenate 'string gfsys::*gf-dir* "src/demos/unblocked/"))
+    (setf *default-pathname-defaults* (parse-namestring *gf-tests-dir*))
     (asdf:operate 'asdf:load-op :graphic-forms-tests)
     (loop for file in '("test-utils.lisp" "mock-objects" "color-unit-tests"
                         "graphics-context-unit-tests" "image-unit-tests"
                         "icon-bundle-unit-tests" "layout-unit-tests"
                         "flow-layout-unit-tests" "widget-unit-tests"
                         "item-manager-unit-tests" "misc-unit-tests")
-          do (load (merge-pathnames file tests-dir)))))
+          do (load (merge-pathnames file *gf-tests-dir*))))