[graphic-forms-cvs] r32 - in trunk: . src src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 6 07:16:31 UTC 2006
Author: junrue
Date: Mon Mar 6 02:16:30 2006
New Revision: 32
Added:
trunk/src/uitoolkit/widgets/event-dispatcher.lisp
Modified:
trunk/build.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/widgets/layout-classes.lisp
trunk/src/uitoolkit/widgets/layouts.lisp
Log:
implemented backend to support :callbacks initarg for event-source instances
Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp (original)
+++ trunk/build.lisp Mon Mar 6 02:16:30 2006
@@ -39,36 +39,40 @@
(defvar *external-build-dirs* nil)
-(defvar *library-root* "c:/projects/third_party/")
-(defvar *project-root* "c:/projects/public/")
+(defvar *library-root* "c:/projects/third_party/")
+(defvar *project-root* "c:/projects/public/")
-(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/"))
+(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/"))
-(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/"))
-(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/"))
-(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/"))
-(defvar *cldoc-dir* (concatenate 'string *asdf-root* "cldoc/"))
-
-(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/"))
-(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/")
-(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/"))
+(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/"))
+(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/"))
+(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/"))
+(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/"))
+(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/"))
+
+(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/"))
+(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/")
+(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/"))
(defvar *asdf-dirs* (list *cffi-dir*
+ *closer-mop-dir*
+ *lw-compat-dir*
*pcl-ch08-dir*
*pcl-ch24-dir*
- *cldoc-dir*
*gf-dir*))
-(defvar *library-build-root* (concatenate 'string *library-root* "build/"))
-(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/"))
-(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/"))
-(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/"))
-(defvar *cldoc-build-dir* (concatenate 'string *library-build-root* "cldoc/"))
+(defvar *library-build-root* (concatenate 'string *library-root* "build/"))
+(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/"))
+(defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/"))
+(defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/"))
+(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/"))
+(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/"))
(defvar *build-dirs* (list *cffi-build-dir*
+ *closer-mop-build-dir*
+ *lw-compat-build-dir*
*pcl-ch08-build-dir*
*pcl-ch24-build-dir*
- *cldoc-build-dir*
*gf-build-dir*))
#+lispworks (defmacro chdir (path)
@@ -87,6 +91,18 @@
(asdf:operate 'asdf:load-op :cffi)
(if *external-build-dirs*
+ (chdir *lw-compat-build-dir*))
+ (asdf:operate 'asdf:load-op :lw-compat)
+
+ (if *external-build-dirs*
+ (chdir *closer-mop-build-dir*))
+ (asdf:operate 'asdf:load-op :closer-mop)
+
+ (if *external-build-dirs*
+ (chdir *cffi-build-dir*))
+ (asdf:operate 'asdf:load-op :cffi)
+
+ (if *external-build-dirs*
(chdir *pcl-ch08-build-dir*))
(asdf:operate 'asdf:load-op :macro-utilities)
@@ -97,14 +113,3 @@
(if *external-build-dirs*
(chdir *gf-build-dir*))
(asdf:operate 'asdf:load-op :graphic-forms-uitoolkit))
-
-;;; FIXME: reference to :cldoc below can't be satisfied yet when
-;;; this file is loaded
-#|
-(defun build-docs ()
- (chdir *gf-doc-dir*)
- (load "c:/projects/third_party/asdf-repo/cldoc/src/cldoc.asd")
- (asdf:operate 'asdf:load-op :cldoc)
- (let ((fn (find-symbol "EXTRACT-DOCUMENTATION" :cldoc)))
- (funcall fn 'cldoc:html *gf-doc-dir* (asdf:find-system 'graphic-forms-uitoolkit))))
-|#
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Mar 6 02:16:30 2006
@@ -431,7 +431,7 @@
#:size
#:startup
#:step-increment
- #:style
+ #:style-of
#:sub-menu
#:text
#:text-height
Added: trunk/src/uitoolkit/widgets/event-dispatcher.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/event-dispatcher.lisp Mon Mar 6 02:16:30 2006
@@ -0,0 +1,89 @@
+;;;;
+;;;; event-dispatcher.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.widgets)
+
+(defun dispatcher-for-activate-callback (class fn)
+ (lispworks:with-unique-names (arg0 arg1 arg2)
+ (let ((gf (clos:ensure-generic-function 'gfw:event-activate
+ :lambda-list (list arg0 arg1 arg2))))
+ (c2mop:ensure-method gf
+ `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2))
+ :specializers (list class
+ (find-class 'gfw:event-source)
+ (find-class 'integer))))))
+
+(defun dispatcher-for-arm-callback (class fn)
+ (lispworks:with-unique-names (arg0 arg1 arg2)
+ (let ((gf (clos:ensure-generic-function 'gfw:event-arm
+ :lambda-list (list arg0 arg1 arg2))))
+ (c2mop:ensure-method gf
+ `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2))
+ :specializers (list class
+ (find-class 'gfw:event-source)
+ (find-class 'integer))))))
+
+(defun dispatcher-for-select-callback (class fn)
+ (lispworks:with-unique-names (arg0 arg1 arg2 arg4)
+ (let ((gf (clos:ensure-generic-function 'gfw:event-select
+ :lambda-list (list arg0 arg1 arg2 arg4))))
+ (c2mop:ensure-method gf
+ `(lambda (,arg0 ,arg1 ,arg2 ,arg4) (funcall ,fn ,arg0 ,arg1 ,arg2 ,arg4))
+ :specializers (list class
+ (find-class 'gfw:item)
+ (find-class 'integer)
+ (find-class 'gfi:rectangle))))))
+
+(defun defdispatcher (callbacks)
+ (let ((class (clos:ensure-class (gensym "EDCLASS") :direct-superclasses '(event-dispatcher))))
+ (loop for pair in callbacks
+ do (cond
+ ((eq (car pair) 'gfw:event-activate)
+ (dispatcher-for-activate-callback class (cdr pair)))
+ ((eq (car pair) 'gfw:event-arm)
+ (dispatcher-for-arm-callback class (cdr pair)))
+ ((eq (car pair) 'gfw:event-select)
+ (dispatcher-for-select-callback class (cdr pair)))
+ (t
+ (error 'gfs:toolkit-error :detail (format nil "unsupported event method for callbacks: ~a"
+ (car pair))))))
+ class))
+
+(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys)
+ "The :callbacks parameter specifies an association list where the CAR is the \
+name of an event-* method (e.g., event-select) and the CDR is a function \
+pointer. As such, this constitutes a specification for a new event-dispatcher \
+object and associated methods."
+ (unless (null callbacks)
+ (let ((class (defdispatcher callbacks)))
+ (setf (dispatcher src) (make-instance (class-name class))))))
Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout-classes.lisp Mon Mar 6 02:16:30 2006
@@ -35,7 +35,7 @@
(defclass layout-manager ()
((style
- :accessor style
+ :accessor style-of
:initarg :style
:initform nil))
(:documentation "Subclasses implement layout strategies on behalf of window objects."))
Modified: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layouts.lisp (original)
+++ trunk/src/uitoolkit/widgets/layouts.lisp Mon Mar 6 02:16:30 2006
@@ -76,7 +76,7 @@
(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
(let ((max -1)
(total 0)
- (vert-orient (find :vertical (gfw:style layout))))
+ (vert-orient (find :vertical (style-of layout))))
(with-children (win kids)
(loop for k in kids
do (let ((kid-size (preferred-size k
@@ -100,7 +100,7 @@
(let ((entries nil)
(last-coord 0)
(last-dim 0)
- (vert-orient (find :vertical (gfw:style layout))))
+ (vert-orient (find :vertical (style-of layout))))
(with-children (win kids)
(loop for k in kids
do (let ((kid-size (preferred-size k
@@ -128,5 +128,5 @@
(unless (listp style)
(setf style (list style)))
(if (and (null (find :horizontal style)) (null (find :vertical style)))
- (setf (slot-value layout 'style) '(:horizontal))
- (setf (slot-value layout 'style) style)))
+ (setf (style-of layout) '(:horizontal))
+ (setf (style-of layout) style)))
More information about the Graphic-forms-cvs
mailing list