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