March 2006 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim/Experimental/freetype
by tmoore 15 Mar '06

15 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv7770/Experimental/freetype Modified Files: freetype-ffi.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-ffi.lisp 2005/08/22 09:28:34 1.3 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-ffi.lisp 2006/03/15 22:56:55 1.4 @@ -3,7 +3,7 @@ (DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien - #+cmucl :alien #+cmucl :c-call) + #+(or cmu scl) :alien #+(or cmu scl) :c-call) (:EXPORT "MEMORY-BASE" "DESCENDER" "LINEAR-VERT-ADVANCE" "YX" "XX" "FREE" "AVAILABLE-SIZES" "COVERAGE" "METRICS" "RASTER-FLAG" "GLYPH" "GET-CHAR-INDEX" "LIMIT" "STRING" "SHIFT" "LEN" "UNDERLINE-POSITION" "RASTER-NEW-FUNC" "POINTS" "TAG" "SIZE-INTERNAL" "NUM-SUBGLYPHS" "UNITS-PER-EM" "LIBRARY" "ALLOC" "OPEN-FACE" "ATTACH-FILE" @@ -42,9 +42,20 @@ (in-package :freetype) -#+cmucl +#+cmu (alien:load-foreign "/usr/lib/libfreetype.so.6") +#+scl +(alien:load-dynamic-object #+64bit "/usr/lib64/libfreetype.so.6" + #-64bit "/usr/lib/libfreetype.so.6") + +#+(or scl cmu) +(defmacro define-alien-type (&rest rest) + `(def-alien-type ,@rest)) +#+(or scl cmu) +(defmacro define-alien-routine (&rest rest) + `(def-alien-routine ,@rest)) + #+sbcl (load-shared-object #+darwin "/usr/X11R6/lib/libfreetype.dylib" #-darwin "libfreetype.so") @@ -373,7 +384,7 @@ (freetype:driver freetype:module) (freetype:num-params freetype:int) (freetype:params (* freetype:parameter)))) (define-alien-routine ("FT_New_Face" freetype:new-face) freetype:error (freetype:library freetype:library) - (freetype::filepathname #+cmucl c-call:c-string #+sbcl c-string) (freetype::face_index freetype:long) (freetype::aface (* (* freetype:face-rec)))) + (freetype::filepathname #+(or cmu scl) c-call:c-string #+sbcl c-string) (freetype::face_index freetype:long) (freetype::aface (* (* freetype:face-rec)))) (define-alien-routine ("FT_New_Memory_Face" freetype:new-memory-face) freetype:error (freetype:library freetype:library) (freetype::file_base (* freetype:byte)) (freetype::file_size freetype:long) (freetype::face_index freetype:long) @@ -403,7 +414,7 @@ (define-alien-routine ("FT_Load_Char" freetype:load-char) freetype:error (freetype:face freetype:face) (freetype::char_code freetype:ulong) (freetype::load_flags freetype:int)) -(define-alien-routine ("FT_Set_Transform" freetype:set-transform) #+cmucl c-call:void #+sbcl void (freetype:face freetype:face) +(define-alien-routine ("FT_Set_Transform" freetype:set-transform) #+(or cmu scl) c-call:void #+sbcl void (freetype:face freetype:face) (freetype:matrix (* freetype:matrix)) (freetype:delta (* freetype:vector))) (define-alien-type freetype:render-mode (enum freetype::render-mode- (:ft-render-mode-normal #.#o0) (:ft-render-mode-mono #.1))) @@ -437,7 +448,7 @@ (define-alien-routine ("FT_FloorFix" freetype:floor-fix) freetype:fixed (freetype::a freetype:fixed)) -(define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) #+cmucl c-call:void #+sbcl void (freetype::vec (* freetype:vector)) +(define-alien-routine ("FT_Vector_Transform" freetype:vector-transform) #+(or cmu scl) c-call:void #+sbcl void (freetype::vec (* freetype:vector)) (freetype:matrix (* freetype:matrix))) (define-alien-type freetype:encoding

1 0

[mcclim-cvs] CVS mcclim/Lisp-Dep
by tmoore 15 Mar '06

15 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv7770/Lisp-Dep Added Files: fix-scl.lisp mp-scl.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-scl.lisp 2006/03/15 22:56:55 NONE +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-scl.lisp 2006/03/15 22:56:55 1.1 ;;;; Support for the Scieneer Common Lisp. ;;;; Gray streams can be defined as subclass of the native stream classes. (in-package :ext) (export '(fundamental-stream fundamental-input-stream fundamental-output-stream fundamental-character-stream fundamental-binary-stream fundamental-character-input-stream fundamental-character-output-stream fundamental-binary-input-stream fundamental-binary-output-stream stream-read-line stream-start-line-p stream-write-string stream-terpri stream-fresh-line stream-advance-to-column ) :ext) (defclass fundamental-stream (stream) () (:documentation "Base class for all CLOS streams")) ;;; Define the stream classes. (defclass fundamental-input-stream (fundamental-stream ext:input-stream) ()) (defclass fundamental-output-stream (fundamental-stream ext:output-stream) ()) (defclass fundamental-character-stream (fundamental-stream ext:character-stream) ()) (defclass fundamental-binary-stream (fundamental-stream ext:binary-stream) ()) (defclass fundamental-character-input-stream (fundamental-input-stream fundamental-character-stream ext:character-input-stream) ()) (defclass fundamental-character-output-stream (fundamental-output-stream fundamental-character-stream ext:character-output-stream) ()) (defclass fundamental-binary-input-stream (fundamental-input-stream fundamental-binary-stream ext:binary-input-stream) ()) (defclass fundamental-binary-output-stream (fundamental-output-stream fundamental-binary-stream ext:binary-output-stream) ()) (defgeneric stream-read-line (stream) (:documentation "Used by 'read-line. A string is returned as the first value. The second value is true if the string was terminated by end-of-file instead of the end of a line. The default method uses repeated calls to 'stream-read-char.")) (defmethod stream-read-line ((stream fundamental-character-input-stream)) (let ((res (make-string 80)) (len 80) (index 0)) (loop (let ((ch (stream-read-char stream))) (cond ((eq ch :eof) (return (values (cl::shrink-vector res index) t))) (t (when (char= ch #\newline) (return (values (cl::shrink-vector res index) nil))) (when (= index len) (setq len (* len 2)) (let ((new (make-string len))) (replace new res) (setq res new))) (setf (schar res index) ch) (incf index))))))) (defgeneric stream-start-line-p (stream)) (defmethod stream-start-line-p ((stream fundamental-character-output-stream)) (eql (stream-line-column stream) 0)) (defgeneric stream-terpri (stream) (:documentation "Writes an end of line, as for TERPRI. Returns NIL. The default method does (STREAM-WRITE-CHAR stream #\NEWLINE).")) (defmethod stream-terpri ((stream fundamental-character-output-stream)) (stream-write-char stream #\Newline)) (defgeneric stream-fresh-line (stream) (:documentation "Outputs a new line to the Stream if it is not positioned at the begining of a line. Returns 't if it output a new line, nil otherwise. Used by 'fresh-line. The default method uses 'stream-start-line-p and 'stream-terpri.")) (defmethod stream-fresh-line ((stream fundamental-character-output-stream)) (unless (stream-start-line-p stream) (stream-terpri stream) t)) (defgeneric stream-advance-to-column (stream column) (:documentation "Writes enough blank space so that the next character will be written at the specified column. Returns true if the operation is successful, or NIL if it is not supported for this stream. This is intended for use by by PPRINT and FORMAT ~T. The default method uses STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL.")) (defmethod stream-advance-to-column ((stream fundamental-character-output-stream) column) (let ((current-column (stream-line-column stream))) (when current-column (let ((fill (- column current-column))) (dotimes (i fill) (stream-write-char stream #\Space))) t))) (defpackage :clim-mop (:use :common-lisp :clos)) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop do (export sym :clim-mop))) (in-package :clim-mop) (eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defconstant clim-lisp-patch::defclass) :clim-lisp-patch)) (defmacro clim-lisp-patch:defconstant (symbol value &optional docu) `(defvar ,symbol ,value ,@(and docu (list docu)))) (defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table)) (defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil)) (defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (eval-when (:compile-toplevel :load-toplevel :execute) (cl:defclass ,name ,@args)))) --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-scl.lisp 2006/03/15 22:56:55 NONE +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-scl.lisp 2006/03/15 22:56:55 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: clim-internals; -*- ;;; --------------------------------------------------------------------------- ;;; Title: CLIM-2, Chapter 32.2 Multi-processing ;;; for the Scieneer Common Lisp ;;; Created: 2006-03-12 ;;; Author: Scieneer Pty Ltd ;;; Based on mp-acl, created 2001-05-22 by Gilbert Baumann ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2006 by Scieneer Pty Ltd ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-internals) (defconstant *multiprocessing-p* t) (eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :clim-mp *features*)) (defun make-process (function &key name) (mp:make-process function :name name)) (defun restart-process (process) (mp:restart-process process)) (defun destroy-process (process) (mp:destroy-process process)) (defun current-process () (mp:current-process)) (defun all-processes () (mp:all-processes)) (defun processp (object) (mp:processp object)) (defun process-name (process) (mp:process-name process)) (defun process-state (process) (mp:process-state process)) (defun process-whostate (process) (mp:process-whostate process)) (defun process-wait (reason predicate) (mp:process-wait reason predicate)) (defun process-wait-with-timeout (reason timeout predicate) (mp:process-wait-with-timeout reason timeout predicate)) (defun process-yield () (mp:process-yield)) (defun process-interrupt (process function) (mp:process-interrupt process function)) (defun disable-process (process) (mp:disable-process process)) (defun enable-process (process) (mp:enable-process process)) (defmacro without-scheduling (&body body) `(mp:without-scheduling ,@body)) (defmacro atomic-incf (place) `(mp:atomic-incf ,place)) (defmacro atomic-decf (place) `(mp:atomic-decf ,place)) ;;; 32.3 Locks (defun make-lock (&optional name) (mp:make-lock name :type :error-check)) (defmacro with-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place (or ,state "Lock Wait")) ,@body)) (defun make-recursive-lock (&optional name) (mp:make-lock name :type :recursive)) (defmacro with-recursive-lock-held ((place &optional state) &body body) `(mp:with-lock-held (,place (or ,state "Lock Wait")) ,@body)) (defun make-condition-variable () (thread:make-cond-var)) (defun condition-wait (condition-variable lock &optional timeout) (cond (timeout (thread:cond-var-timedwait condition-variable lock timeout)) (t (thread:cond-var-wait condition-variable lock) t))) (defun condition-notify (condition-variable) (thread:cond-var-broadcast condition-variable))

1 0

[mcclim-cvs] CVS mcclim
by tmoore 15 Mar '06

15 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7770 Modified Files: README mcclim.asd package.lisp presentations.lisp stream-input.lisp system.lisp utils.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too. --- /project/mcclim/cvsroot/mcclim/README 2004/12/20 15:47:32 1.2 +++ /project/mcclim/cvsroot/mcclim/README 2006/03/15 22:56:54 1.3 @@ -2,7 +2,9 @@ This is McCLIM, an implementation of the "Common Lisp Interface Manager CLIM II Specification." It currently works on X Windows using -CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL and LispWorks. +CLX. It works with CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, +and the Scieneer CL. + The INSTALL files in this directory give instructions for each Lisp implementation. Release notes for each release of McCLIM are in the ReleaseNotes directory. @@ -22,7 +24,7 @@ address-book - the canonical CLIM application clim-fig - a drawing program -postscript-test - shows of the CLIM PostScript stream +postscript-test - shows off the CLIM PostScript stream gadget-test - fun with CLIM gadgets calculator - a gadget-based calculator goatee-test - Hacks with Goatee, the Emacs-like editor used in McCLIM --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 15:38:39 1.9 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 22:56:54 1.10 @@ -85,6 +85,7 @@ :depends-on ("patch") :components ((:file #+cmu "fix-cmu" + #+scl "fix-scl" #+excl "fix-acl" #+sbcl "fix-sbcl" #+openmcl "fix-openmcl" @@ -101,6 +102,7 @@ :components ((:file #.(or #+(and :cmu :mp (not :pthread)) "mp-cmu" + #+scl "mp-scl" #+sb-thread "mp-sbcl" #+excl "mp-acl" #+openmcl "mp-openmcl" @@ -289,7 +291,7 @@ :depends-on (:clim ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(or sbcl openmcl ecl clx allegro) :clim-clx + #+(or sbcl scl openmcl ecl clx allegro) :clim-clx #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). --- /project/mcclim/cvsroot/mcclim/package.lisp 2006/01/28 00:38:04 1.52 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2006/03/15 22:56:54 1.53 @@ -219,6 +219,7 @@ (gray-packages `(#+clisp ,@'(:gray) #+cmu ,@'(:ext) + #+scl ,@'(:ext) #+mcl ,@'(:ccl) #+allegro ,@'(:common-lisp :excl :stream) #+harlequin-common-lisp ,@'(:stream) --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 15:38:39 1.74 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 22:56:54 1.75 @@ -910,6 +910,7 @@ (defvar *standard-object-class* (find-class 'standard-object)) +#-scl (defmethod clim-mop:compute-applicable-methods-using-classes :around ((gf presentation-generic-function) classes) (multiple-value-bind (methods success) @@ -924,7 +925,24 @@ *standard-object-class*)) methods) t))))) - + +#+scl +(defmethod clim-mop:compute-applicable-methods-using-classes :around + ((gf presentation-generic-function) classes) + (multiple-value-bind (methods success non-class-positions) + (call-next-method) + (let ((ptype-class (car classes))) + (if (or (null success) + (not (typep ptype-class 'presentation-type-class))) + (values methods non-class-positions non-class-positions) + (values (remove-if #'(lambda (method) + (eq (car (clim-mop:method-specializers + method)) + *standard-object-class*)) + methods) + t + non-class-positions))))) + (defun method-applicable (method arguments) (loop for arg in arguments for specializer in (clim-mop:method-specializers method) --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 15:38:39 1.45 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 22:56:54 1.46 @@ -117,6 +117,15 @@ else do (handle-event (event-sheet event) event)))) +(defmethod stream-clear-input ((pane standard-input-stream)) + (setf (stream-unread-chars pane) nil) + (loop for event = (event-read-no-hang pane) + if (null event) + return nil + else + do (handle-event (event-sheet event) event)) + nil) + ;;; XXX The should be moved to protocol-classes.lisp and the ;;; standard-sheet-input-mixin superclass should be removed. (define-protocol-class extended-input-stream (fundamental-character-input-stream ;Gray stream @@ -384,6 +393,18 @@ do (stream-read-gesture estream) ; consume pointer gesture finally (return (characterp char))))) +(defmethod stream-clear-input ((stream standard-extended-input-stream)) + (with-encapsulating-stream (estream stream) + (loop + with char and reason + do (setf (values char reason) (stream-read-gesture estream + :timeout 0 + :peek-p t)) + until (or (eq reason :eof) (eq reason :timeout)) + do (stream-read-gesture estream) ; consume pointer gesture + )) + nil) + ;;; stream-read-line returns a second value of t if terminated by eof. (defmethod stream-read-line ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) --- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 15:38:39 1.114 +++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 22:56:54 1.115 @@ -80,6 +80,7 @@ ;; First possible patches "patch" #+cmu "Lisp-Dep/fix-cmu" + #+scl "Lisp-Dep/fix-scl" #+excl "Lisp-Dep/fix-acl" #+sbcl "Lisp-Dep/fix-sbcl" #+openmcl "Lisp-Dep/fix-openmcl" @@ -101,6 +102,7 @@ #+excl "Lisp-Dep/mp-acl" #+openmcl "Lisp-Dep/mp-openmcl" #+lispworks "Lisp-Dep/mp-lw" + #+scl "Lisp-Dep/mp-scl" #| fall back |# "Lisp-Dep/mp-nil") "utils" "defresource" --- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 15:38:39 1.44 +++ /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 22:56:54 1.45 @@ -21,12 +21,12 @@ (defun get-environment-variable (string) #+excl (sys:getenv string) - #+cmu (cdr (assoc string ext:*environment-list* :test #'string=)) + #+(or cmu scl) (cdr (assoc string ext:*environment-list* :test #'string=)) #+clisp (ext:getenv (string string)) #+sbcl (sb-ext::posix-getenv string) #+openmcl (ccl::getenv string) #+lispworks (lw:environment-variable string) - #-(or excl cmu clisp sbcl openmcl lispworks) + #-(or excl cmu scl clisp sbcl openmcl lispworks) (error "GET-ENVIRONMENT-VARIABLE not implemented")) ;;; It would be nice to define this macro in terms of letf, but that

1 0

[mcclim-cvs] CVS mcclim
by tmoore 15 Mar '06

15 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18917 Modified Files: builtin-commands.lisp commands.lisp decls.lisp frames.lisp mcclim.asd presentation-defs.lisp presentations.lisp stream-input.lisp system.lisp utils.lisp Log Message: Fixed destination highlighting for drag-and-drop translators. Added documentation for dnd translators. Corrected the default value for modifier-state in find-innermost-applicable-presentation and friends. This isn't as big as it looks :) --- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2005/06/22 11:41:34 1.20 +++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/15 15:38:38 1.21 @@ -136,7 +136,9 @@ :for-menu t)) ;;; Action for possibilities menu of complete-input - +;;; +;;; XXX The context type needs to change to COMPLETER or something so that this +;;; isn't applicable all over the place. (define-presentation-action possibilities-menu (blank-area nil global-command-table :documentation "Possibilities menu for completion" --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/10 21:58:12 1.58 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/15 15:38:39 1.59 @@ -178,19 +178,6 @@ :menu ',menu :errorp nil)))) -(defun command-name-from-symbol (symbol) - (let ((name (symbol-name symbol))) - (string-capitalize - (substitute - #\Space #\- - (subseq name (if (string= "COM-" name :end2 (min (length name) 4)) - 4 - 0)))))) - -(defun keyword-arg-name-from-symbol (symbol) - (let ((name (symbol-name symbol))) - (string-capitalize (substitute #\Space #\- name)))) - (defun remove-command-from-command-table (command-name command-table &key (errorp t)) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/10 21:58:12 1.36 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/15 15:38:39 1.37 @@ -502,6 +502,10 @@ (defgeneric port-disable-sheet (port sheet)) (defgeneric port-pointer (port)) +(defgeneric pointer-update-state (pointer event) + (:documentation "Called by port event dispatching code to update the modifier +and button states of the pointer.")) + ;;; ;; Used in stream-input.lisp, defined in frames.lisp --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/13 06:08:12 1.116 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/15 15:38:39 1.117 @@ -1460,17 +1460,19 @@ ;;; Classic CLIM seems to agree. -- moore (defun highlight-for-tracking-pointer (frame stream event input-context highlight) - (let ((context-ptype (input-context-type (car input-context))) - (presentation nil) + (let ((presentation nil) (current-hilited (frame-hilited-presentation frame))) (when (output-recording-stream-p stream) - (setq presentation (find-innermost-applicable-presentation - input-context - stream - (device-event-x event) - (device-event-y event) - :frame frame - :event event))) + ;; XXX Massive hack to prevent the presentation action for completions + ;; from being applicable. After the .9.2.2 release that action will have + ;; a more restrictive context type. + (let ((*completion-possibilities-continuation* nil)) + (setq presentation (find-innermost-applicable-presentation + input-context + stream + (device-event-x event) + (device-event-y event) + :frame frame)))) (when (and current-hilited (not (eq (car current-hilited) presentation))) (highlight-presentation-1 (car current-hilited) (cdr current-hilited) @@ -1641,7 +1643,7 @@ (tracking-pointer (window :context-type `(or ,(mapcar #'from-type translators)) :highlight nil - :multiple-window t) + :multiple-window nil) ;XXX (:presentation (&key presentation window event x y) (let ((dest-translator (find-dest-translator presentation window x y))) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/10 21:58:13 1.8 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 15:38:39 1.9 @@ -321,7 +321,8 @@ (:file "presentation-test") #+clx (:file "gadget-test") (:file "accepting-values") - (:file "method-browser"))))) + (:file "method-browser") + (:file "dragndrop-translator"))))) ;;; This won't load in SBCL, either. I have really crappy code to ;;; extract dependency information from :serial t ASDF systems, but --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/12 23:09:27 1.52 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/15 15:38:39 1.53 @@ -2047,7 +2047,7 @@ (gesture :select) (tester 'default-translator-tester) documentation - pointer-documentation + (pointer-documentation nil pointer-doc-p) (menu t) (priority 0) (feedback 'frame-drag-and-drop-feedback) @@ -2056,14 +2056,25 @@ &body body) (declare (ignore tester gesture documentation pointer-documentation menu priority)) - (let ((real-dest-type (expand-presentation-type-abbreviation - destination-type))) - - (with-keywords-removed (args (:feedback :highlighting)) + (let* ((real-dest-type (expand-presentation-type-abbreviation + destination-type)) + (name-string (command-name-from-symbol name)) + (drag-string (format nil "Drag to ~A" name-string)) + (pointer-doc (if pointer-doc-p + nil + `(:pointer-documentation + ((object destination-object stream) + (declare (ignore object)) + (write-string (if destination-object + ,name-string + ,drag-string) + stream)))))) + (with-keywords-removed (args (:feedback :highlighting)) `(progn (define-presentation-translator ,name (,from-type ,to-type ,command-table ,@args + ,@pointer-doc :feedback #',feedback :highlighting #',highlighting :destination-ptype ',real-dest-type :destination-translator #',(make-translator-fun arglist body) --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/12 23:09:27 1.73 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 15:38:39 1.74 @@ -1598,8 +1598,6 @@ x y) context-type)) (return-from test-presentation-translator nil)))) - - t) ;;; presentation-contains-position moved to presentation-defs.lisp @@ -1661,9 +1659,14 @@ presentation x y))))) +(defun window-modifier-state (window) + "Provides default modifier state for presentation translator functions." + (let ((pointer (port-pointer (port window)))) + (pointer-modifier-state pointer))) + (defun find-applicable-translators (presentation input-context frame window x y - &key event (modifier-state 0) for-menu fastp) + &key event (modifier-state (window-modifier-state window)) for-menu fastp) (let ((results nil)) (flet ((fast-func (translator presentation context) (declare (ignore translator presentation context)) @@ -1751,7 +1754,9 @@ (defun find-innermost-applicable-presentation (input-context window x y - &key (frame *application-frame*) modifier-state event) + &key (frame *application-frame*) + (modifier-state (window-modifier-state window)) + event) (values (find-innermost-presentation-match input-context (stream-output-history window) frame @@ -1761,12 +1766,13 @@ modifier-state nil))) -(defun find-innermost-presentation-context (input-context window x y - &key - (top-record - (stream-output-history window)) - (frame *application-frame*) - event modifier-state button) +(defun find-innermost-presentation-context + (input-context window x y + &key (top-record (stream-output-history window)) + (frame *application-frame*) + event + (modifier-state (window-modifier-state window)) + button) (find-innermost-presentation-match input-context top-record frame --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/10 21:58:13 1.44 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 15:38:39 1.45 @@ -644,7 +644,10 @@ ;;; backends. (defclass standard-pointer (pointer) - ((port :reader port :initarg :port))) + ((port :reader port :initarg :port) + (state-lock :reader state-lock :initform (make-lock "pointer lock")) + (button-state :initform 0 ) + (modifier-state :initform 0))) (defgeneric pointer-sheet (pointer)) @@ -680,8 +683,37 @@ (with-accessors ((port-pointer-sheet port-pointer-sheet)) (port sheet) (when (eq port-pointer-sheet sheet) + (setq port-pointer-sheet nil)))) +(defmethod pointer-button-state ((pointer standard-pointer)) + (with-lock-held ((state-lock pointer)) + (slot-value pointer 'button-state))) + +(defmethod pointer-modifier-state ((pointer standard-pointer)) + (with-lock-held ((state-lock pointer)) + (slot-value pointer 'modifier-state))) + +(defmethod pointer-update-state + ((pointer standard-pointer) (event keyboard-event)) + (with-lock-held ((state-lock pointer)) + (setf (slot-value pointer 'modifier-state) (event-modifier-state event)))) + +(defmethod pointer-update-state + ((pointer standard-pointer) (event pointer-button-press-event)) + (with-lock-held ((state-lock pointer)) + (setf (slot-value pointer 'button-state) + (logior (slot-value pointer 'button-state) + (pointer-event-button event))))) + +(defmethod pointer-update-state + ((pointer standard-pointer) (event pointer-button-release-event)) + (with-lock-held ((state-lock pointer)) + (setf (slot-value pointer 'button-state) + (logandc2 (slot-value pointer 'button-state) + (pointer-event-button event))))) + +(defmethod pointer-butt) (defgeneric stream-pointer-position (stream &key pointer)) (defmethod stream-pointer-position ((stream standard-extended-input-stream) --- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/10 21:58:13 1.113 +++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 15:38:39 1.114 @@ -89,6 +89,7 @@ (clim-defsystem (:clim-core :depends-on (:clim-lisp)) "decls" + "protocol-classes" #.(or #+(and :cmu :mp (not :pthread)) "Lisp-Dep/mp-cmu" @@ -213,6 +214,7 @@ "Examples/dragndrop" "Examples/gadget-test" "Examples/method-browser" + "Examples/dragndrop-translator" "Goatee/goatee-test" "Examples/accepting-values") --- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/10 21:58:13 1.43 +++ /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 15:38:39 1.44 @@ -574,3 +574,18 @@ (intern (symbol-name obj) :keyword)) (string (intern (string-upcase obj) :keyword)))) + +;;; Command name utilities that are useful elsewhere. + +(defun command-name-from-symbol (symbol) + (let ((name (symbol-name symbol))) + (string-capitalize + (substitute + #\Space #\- + (subseq name (if (string= '#:com- name :end2 (min (length name) 4)) + 4 + 0)))))) + +(defun keyword-arg-name-from-symbol (symbol) + (let ((name (symbol-name symbol))) + (string-capitalize (substitute #\Space #\- name))))

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by crhodes 15 Mar '06

15 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv4599/Experimental/freetype Modified Files: mcclim-freetype.asd Log Message: Fix for uncompiled-cl-source-file in the presence of the (advertised) asdf protocol with output-files :around. No output files! --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2006/02/06 13:42:09 1.4 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2006/03/15 09:31:31 1.5 @@ -12,13 +12,20 @@ (defpackage :mcclim-freetype-system (:use :cl :asdf)) (in-package :mcclim-freetype-system) -(defclass uncompiled-cl-source-file (cl-source-file) ()) +(defclass uncompiled-cl-source-file (source-file) ()) (defmethod perform ((o compile-op) (f uncompiled-cl-source-file)) t) - +(defmethod perform ((o load-op) (f uncompiled-cl-source-file)) + (mapcar #'load (input-files o f))) (defmethod output-files ((operation compile-op) (c uncompiled-cl-source-file)) + nil) +(defmethod input-files ((operation load-op) (c uncompiled-cl-source-file)) (list (component-pathname c))) +(defmethod operation-done-p ((operation compile-op) (c uncompiled-cl-source-file)) + t) +(defmethod source-file-type ((c uncompiled-cl-source-file) (s module)) + "lisp") (defsystem :mcclim-freetype :depends-on (:clim-clx)

1 0

[mcclim-cvs] CVS mcclim/Goatee
by crhodes 14 Mar '06

14 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv4322/Goatee Modified Files: goatee-command.lisp Log Message: Latin1 commands for Goatee. Requires, in the case of the CLX backend, SBCL and a post-0.7.2 CLX. --- /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/03/11 11:25:03 1.21 +++ /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/03/14 12:27:24 1.22 @@ -261,6 +261,11 @@ do (add-gesture-command-to-table (code-char i) 'insert-character *simple-area-gesture-table*)) +;;; people who use dead keys get to implement code for that in Goatee. +(loop for i from 160 to 255 + do (add-gesture-command-to-table (code-char i) + 'insert-character + *simple-area-gesture-table*)) (add-gesture-command-to-table #\tab 'insert-character

1 0

[mcclim-cvs] CVS mcclim/Examples
by tmoore 13 Mar '06

13 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv11856 Modified Files: dragndrop-translator.lisp Log Message: Remove some debugging code that breaks everything --- /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 11:24:01 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 17:06:08 1.3 @@ -80,12 +80,7 @@ (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color - (rect command rect drag-test - :tester ((destination-object event) - (when destination-object - (break)) - event - t)) + (rect command rect drag-test) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object)

1 0

[mcclim-cvs] CVS mcclim/Examples
by tmoore 13 Mar '06

13 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv32650 Modified Files: dragndrop-translator.lisp Log Message: Missing eval-when --- /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 06:13:05 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 11:24:01 1.2 @@ -23,14 +23,15 @@ (defparameter *colors* (list +black+ +white+ +red+ +green+ +blue+ +magenta+ +cyan+ +yellow+)) -(defparameter *color-alist* `(("black" . ,+black+) - ("white" . ,+white+) - ("red" . ,+red+) - ("green" . ,+green+) - ("blue" . ,+blue+) - ("magenta" . ,+magenta+) - ("cyan" . ,+cyan+) - ("yellow" . ,+yellow+))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *color-alist* `(("black" . ,+black+) + ("white" . ,+white+) + ("red" . ,+red+) + ("green" . ,+green+) + ("blue" . ,+blue+) + ("magenta" . ,+magenta+) + ("cyan" . ,+cyan+) + ("yellow" . ,+yellow+)))) (define-presentation-type named-color () :inherit-from `(completion ,*color-alist* :value-key cdr)) @@ -79,7 +80,12 @@ (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color - (rect command rect drag-test) + (rect command rect drag-test + :tester ((destination-object event) + (when destination-object + (break)) + event + t)) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object)

1 0

[mcclim-cvs] CVS mcclim/Examples
by tmoore 13 Mar '06

13 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv28215 Added Files: dragndrop-translator.lisp Log Message: Test program for drag-and-drop translators --- /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 06:13:05 NONE +++ /project/mcclim/cvsroot/mcclim/Examples/dragndrop-translator.lisp 2006/03/13 06:13:05 1.1 ;;; -*- Mode: Lisp; Package: CLIM-DEMO -*- ;;; (c) copyright 2006 by ;;; Tim Moore (moore(a)bricoworks.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :clim-demo) (defparameter *colors* (list +black+ +white+ +red+ +green+ +blue+ +magenta+ +cyan+ +yellow+)) (defparameter *color-alist* `(("black" . ,+black+) ("white" . ,+white+) ("red" . ,+red+) ("green" . ,+green+) ("blue" . ,+blue+) ("magenta" . ,+magenta+) ("cyan" . ,+cyan+) ("yellow" . ,+yellow+))) (define-presentation-type named-color () :inherit-from `(completion ,*color-alist* :value-key cdr)) (defclass rect () ((x :accessor x :initarg :x) (y :accessor y :initarg :y) (width :accessor width :initarg :width) (height :accessor height :initarg :height) (color :accessor color :initarg :color)) (:default-initargs :x 0 :y 0 :width 50 :height 50 :color +black+)) (defgeneric draw (stream thing)) (defmethod draw (stream (thing rect)) (with-output-as-presentation (stream thing 'rect) (let ((x (x thing)) (y (y thing))) (draw-rectangle* stream x y (+ x (width thing)) (+ y (height thing)) :ink (color thing))))) (define-application-frame drag-test () ((shape1 :accessor shape1 :initform (make-instance 'rect :x 10 :y 10)) (shape2 :accessor shape2 :initform (make-instance 'rect :x 100 :y 10))) (:pointer-documentation t) (:panes (interactor :interactor) (scribble :application :width 200 :display-function 'display-shapes)) (:layouts (default (vertically () scribble interactor)))) (defun display-shapes (frame stream) (draw stream (shape1 frame)) (draw stream (shape2 frame))) (define-drag-test-command (com-set-color :name t) ((shape 'rect) &key (color 'named-color :default +cyan+ )) (setf (color shape) color)) (define-drag-test-command (com-set-random-color :name t) ((shape 'rect)) (let ((elt (random (length *color-alist*)))) (setf (color shape) (cdr (nth elt *color-alist*))))) (define-drag-and-drop-translator com-drop-color (rect command rect drag-test) (object destination-object) (if (eq object destination-object) `(com-set-random-color ,object) `(com-set-color ,destination-object :color ,(color object)))) #-(and) (define-gesture-name :drag-and-drop :pointer-button (:control :left) :unique t)

1 0

[mcclim-cvs] CVS mcclim
by tmoore 13 Mar '06

13 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv28040 Modified Files: frames.lisp Log Message: drag-and-drop mostly working except for highlighting of destination presentations --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/12 23:09:27 1.115 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/13 06:08:12 1.116 @@ -1562,7 +1562,7 @@ :filled nil :line-dashes #(4 4)))) (:unhighlight (with-double-buffering - ((stream hilite-x1 hilite-y1 hilite-x2 hilite-y2) + ((stream hilite-x1 hilite-y1 (1+ hilite-x2) (1+ hilite-y2)) (buffer-rectangle)) (stream-replay stream buffer-rectangle)))))))) @@ -1590,7 +1590,8 @@ :window window :x x :y y - :event event))) + :event event) + (list trans))) (find-presentation-translators (presentation-type from-presentation) context-type @@ -1623,13 +1624,11 @@ window x y)) do (return-from find-dest-translator translator)) nil) - (do-feedback (window x y state do-it) - (when do-it - (funcall feedback-fn frame from-presentation window - initial-x initial-y x y state))) + (do-feedback (window x y state) + (funcall feedback-fn frame from-presentation window + initial-x initial-y x y state)) (do-hilite (presentation window state) - (when presentation - (funcall hilite-fn frame presentation window state))) + (funcall hilite-fn frame presentation window state)) (last-window () (event-sheet last-event)) (last-x () @@ -1646,27 +1645,29 @@ (:presentation (&key presentation window event x y) (let ((dest-translator (find-dest-translator presentation window x y))) - (do-feedback (last-window) (last-x) (last-y) - :unhighlight feedback-activated) + (when feedback-activated + (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (setq feedback-activated t last-event event) - (do-hilite last-presentation (last-window) :unhighlight) + (when last-presentation + (do-hilite last-presentation (last-window) :unhighlight)) (setq last-presentation presentation feedback-fn (feedback dest-translator) hilite-fn (highlighting dest-translator)) (do-hilite presentation window :highlight) - (do-feedback window x y :highlight t) + (do-feedback window x y :highlight) (document-drag-n-drop dest-translator presentation context-type frame event window x y))) (:pointer-motion (&key event window x y) - (do-feedback (last-window) (last-x) (last-y) - :unhighlight feedback-activated) + (when feedback-activated + (do-feedback (last-window) (last-x) (last-y) :unhighlight)) (setq feedback-activated t last-event event) - (do-hilite last-presentation (last-window) :unhighlight) + (when last-presentation + (do-hilite last-presentation (last-window) :unhighlight)) (setq last-presentation nil) - (do-feedback window x y :highlight t) + (do-feedback window x y :highlight) (document-drag-n-drop translator nil context-type frame event window x y)) @@ -1683,9 +1684,10 @@ ;; ;; XXX Assumes x y from :button-release are the same as for the preceding ;; button-motion; is that correct? - (do-feedback (last-window) (last-x) (last-y) - :unhighlight feedback-activated) - (do-hilite last-presentation (last-window) :unhighlight) + (when feedback-activated + (do-feedback (last-window) (last-x) (last-y) :unhighlight)) + (when last-presentation + (do-hilite last-presentation (last-window) :unhighlight)) (if destination-presentation (let ((final-translator (find-dest-translator destination-presentation (last-window) @@ -1714,14 +1716,19 @@ (window-clear s) (with-end-of-page-action (s :allow) (with-end-of-line-action (s :allow) - (document-presentation-translator translator - presentation - context-type - frame - event - window - x y - :stream s - :documentation-type :pointer)))))) + (funcall (pointer-documentation translator) + *dragged-object* + :presentation *dragged-presentation* + :destination-object (and presentation + (presentation-object presentation)) + :destination-presentation presentation + :context-type context-type + :frame frame + :event event + :window window + :x x + :y y + :stream s)))))) +

1 0