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

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by mretzlaff＠common-lisp.net 26 Aug '05

26 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12901 Modified Files: dialog.lisp Log Message: (climi::frame-event-queue *application-frame*) as argument :INPUT-BUFFER to the call of OPEN-WINDOW-STREAM in WITH-STREAM-IN-OWN-WINDOW (was not specified previously). The ugly delay could be dropped, because no new process is created anymore. See http://common-lisp.net/pipermail/mcclim-devel/2005-August/004239.html for more information. (Thanks go to Christophe.) The parameter :LABEL to ACCEPTING-VALUES will now actually be used to label the newly created window if :OWN-WINDOW is true. Date: Fri Aug 26 02:32:56 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.21 mcclim/dialog.lisp:1.22 --- mcclim/dialog.lisp:1.21 Thu Aug 25 22:48:40 2005 +++ mcclim/dialog.lisp Fri Aug 26 02:32:56 2005 @@ -138,12 +138,13 @@ (defmacro with-stream-in-own-window ((&optional (stream '*query-io*) &rest further-streams) + (&optional label) &rest body) - `(let* ((,stream (open-window-stream)) + `(let* ((,stream (open-window-stream :label ,label + :input-buffer (climi::frame-event-queue *application-frame*))) ,@(mapcar (lambda (a-stream) (list a-stream stream)) further-streams)) - (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened (unwind-protect (progn ,@body) @@ -159,7 +160,7 @@ &body body) (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame - align-prompts label scroll-bars + align-prompts scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) @@ -171,7 +172,9 @@ ,@args)) )) `(if ,own-window - (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + (with-stream-in-own-window (,stream *standard-input* *standard-output*) + (,label) + ,return-form) ,return-form)))) (defun invoke-accepting-values

2 2

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by mretzlaff＠common-lisp.net 25 Aug '05

25 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26547 Modified Files: dialog.lisp Log Message: A patch against the first bug a patch by me introduced to mcclim. Sorry, that shouldn't have happened.. At least it was only a bug in a feature that the patch introduced (displaying an ACCEPTING-VALUES dialog in its :OWN-WINDOW), and it affected only code that thoughtlessly relied of this new and still broken feature. (Broken because OPEN-WINDOW-STREAM doesn't really work yet. I think there has to be a (redisplay-frame-panes frame) or something like that in its event-loop (that is the function STANDALONE-EVENT-LOOP).) Date: Thu Aug 25 22:48:41 2005 Author: mretzlaff Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.20 mcclim/dialog.lisp:1.21 --- mcclim/dialog.lisp:1.20 Fri Aug 19 02:48:25 2005 +++ mcclim/dialog.lisp Thu Aug 25 22:48:40 2005 @@ -170,9 +170,9 @@ #',accepting-values-continuation ,@args)) )) - (if own-window - `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) - return-form)))) + `(if ,own-window + (with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + ,return-form)))) (defun invoke-accepting-values (stream body

1 0

[mcclim-cvs] CVS update: mcclim/presentation-defs.lisp
by mretzlaff＠common-lisp.net 25 Aug '05

25 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23472 Modified Files: presentation-defs.lisp Log Message: This patch HANDLER-BINDs the ABORT-GESTURE condition to #'abort for the function ACCEPT in presentation-defs.lisp. ABORT-GESTURE is the condition that is signaled when any of the gestures in *ABORT-GESTURES* is read (in STREAM-READ-GESTURE). Right now *ABORT-GESTURES* contains only :abort on mcclim, which is a the keyboard gesture (#\c :control) (on Genera it contains #\Abort, the ABORT-key). I do not find explicitly in the clim specification that an ACCEPT should be aborted on an ABORT-GESTURE, but it seems to be the right thing (and I have to admit that I haven't been looking very hard). I did short tests with ACCEPTING-VALUES and it seems to behave correctly with this patch, i.e. the whole dialog will be aborted. But perhaps it would be nicer if, as long as a gadget of the dialog is selected, only the edit of that gadget were aborted. Date: Thu Aug 25 22:24:12 2005 Author: mretzlaff Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.45 mcclim/presentation-defs.lisp:1.46 --- mcclim/presentation-defs.lisp:1.45 Mon Aug 8 19:15:07 2005 +++ mcclim/presentation-defs.lisp Thu Aug 25 22:24:10 2005 @@ -664,71 +664,72 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (let* ((real-type (expand-presentation-type-abbreviation type)) - (real-default-type (cond (default-type-p - (expand-presentation-type-abbreviation - default-type)) - ((or defaultp provide-default) - real-type) - (t nil))) - (real-history-type (cond ((null historyp) real-type) - ((null history) nil) - (t (expand-presentation-type-abbreviation - history)))) - (*recursive-accept-p* *recursive-accept-1-p*) - (*recursive-accept-1-p* t)) - (with-keywords-removed (rest-args (:stream)) - (when (or default-type-p defaultp) - (setf rest-args - (list* :default-type real-default-type rest-args))) - (when historyp - (setf rest-args (list* :history real-history-type rest-args))) - (cond ((and viewp (symbolp view)) - (setf rest-args - (list* :view (funcall #'make-instance view) rest-args))) - ((consp view) - (setf rest-args - (list* :view (apply #'make-instance view) rest-args)))) - ;; Presentation type history interaction. According to the spec, - ;; if provide-default is true, we take the default from the - ;; presentation history. In addition, we'll implement the Genera - ;; behavior of temporarily putting the default on the history - ;; stack so the user can conveniently suck it in. - (flet ((do-accept (args) - (apply #'stream-accept stream real-type args)) - (get-history () - (when real-history-type - (funcall-presentation-generic-function - presentation-type-history-for-stream - real-history-type stream)))) - (let* ((default-from-history (and (not defaultp) provide-default)) - (history (get-history)) - (results - (multiple-value-list - (if history - (let ((*active-history-type* real-history-type)) - (cond (defaultp - (with-object-on-history - (history default real-default-type) - (do-accept rest-args))) - (default-from-history - (multiple-value-bind - (history-default history-type) - (presentation-history-head history - real-default-type) - (do-accept (if history-type - (list* :default history-default - :default-type history-type - rest-args) - rest-args)))) - (t (do-accept rest-args)))) - (do-accept rest-args)))) - (results-history (get-history))) - (when results-history - (presentation-history-add results-history - (car results) - (cadr results))) - (values-list results)))))) + (handler-bind ((abort-gesture #'abort)) + (let* ((real-type (expand-presentation-type-abbreviation type)) + (real-default-type (cond (default-type-p + (expand-presentation-type-abbreviation + default-type)) + ((or defaultp provide-default) + real-type) + (t nil))) + (real-history-type (cond ((null historyp) real-type) + ((null history) nil) + (t (expand-presentation-type-abbreviation + history)))) + (*recursive-accept-p* *recursive-accept-1-p*) + (*recursive-accept-1-p* t)) + (with-keywords-removed (rest-args (:stream)) + (when (or default-type-p defaultp) + (setf rest-args + (list* :default-type real-default-type rest-args))) + (when historyp + (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) + ;; Presentation type history interaction. According to the spec, + ;; if provide-default is true, we take the default from the + ;; presentation history. In addition, we'll implement the Genera + ;; behavior of temporarily putting the default on the history + ;; stack so the user can conveniently suck it in. + (flet ((do-accept (args) + (apply #'stream-accept stream real-type args)) + (get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream)))) + (let* ((default-from-history (and (not defaultp) provide-default)) + (history (get-history)) + (results + (multiple-value-list + (if history + (let ((*active-history-type* real-history-type)) + (cond (defaultp + (with-object-on-history + (history default real-default-type) + (do-accept rest-args))) + (default-from-history + (multiple-value-bind + (history-default history-type) + (presentation-history-head history + real-default-type) + (do-accept (if history-type + (list* :default history-default + :default-type history-type + rest-args) + rest-args)))) + (t (do-accept rest-args)))) + (do-accept rest-args)))) + (results-history (get-history))) + (when results-history + (presentation-history-add results-history + (car results) + (cadr results))) + (values-list results))))))) (defgeneric stream-accept (stream type &key

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/freetype/freetype-ffi.lisp
by crhodes＠common-lisp.net 22 Aug '05

22 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory common-lisp.net:/tmp/cvs-serv12313 Modified Files: freetype-ffi.lisp Log Message: Make the Freetype FFI 32/64 agnostic. Untested on CMUCL, but I don't think the previous version worked on CMUCL either. Date: Mon Aug 22 11:28:35 2005 Author: crhodes Index: mcclim/Experimental/freetype/freetype-ffi.lisp diff -u mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 mcclim/Experimental/freetype/freetype-ffi.lisp:1.3 --- mcclim/Experimental/freetype/freetype-ffi.lisp:1.2 Sun Jun 5 22:50:29 2005 +++ mcclim/Experimental/freetype/freetype-ffi.lisp Mon Aug 22 11:28:34 2005 @@ -1,6 +1,9 @@ ;;; automatically generated, hand tweaked, do not regenerate. -(DEFPACKAGE :FREETYPE (:USE :cl #+sbcl :sb-alien #+cmucl :alien) +(DEFPACKAGE :FREETYPE + (:USE :cl + #+sbcl :sb-alien + #+cmucl :alien #+cmucl :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" @@ -37,8 +40,6 @@ "BITMAP-" "FILE_BASE" "KERN_MODE" "CHAR_CODE" "RENDERER-REC-" "RASTER-REC-" "VECTOR-" "SIZE-METRICS-" "CHAR_WIDTH" "GENERIC-" "ENCODING-" "FACE_INDEX" "SLOT" "GLYPH-FORMAT-" "OPEN-ARGS-" "BBOX-" "SIZE_S")) -;;(declaim (sb-ext:muffle-conditions sb-int:deprecation-warning)) - (in-package :freetype) #+cmucl @@ -75,6 +76,52 @@ (define-alien-type freetype:ufast (unsigned 32)) +(define-alien-type freetype:ptrdiff-t (signed 32)) + +(define-alien-type freetype:size-t (unsigned 32)) + +(define-alien-type freetype:wchar-t (signed 32)) + +(define-alien-type freetype:wint-t (unsigned 32)) + +(define-alien-type freetype:bool (unsigned 8)) + +(define-alien-type freetype:fword (signed 16)) + +(define-alien-type freetype:ufword (unsigned 16)) + +(define-alien-type freetype:char (signed 8)) + +(define-alien-type freetype:byte (unsigned 8)) + +(define-alien-type freetype:string (signed 8)) + +(define-alien-type freetype:short (signed 16)) + +(define-alien-type freetype:ushort (unsigned 16)) + +(define-alien-type freetype:int (signed 32)) + +(define-alien-type freetype:uint (unsigned 32)) + +(define-alien-type freetype:long long) + +(define-alien-type freetype:ulong unsigned-long) + +(define-alien-type freetype:f2dot14 (signed 16)) + +(define-alien-type freetype:f26dot6 long) + +(define-alien-type freetype:fixed long) + +(define-alien-type freetype:error (signed 32)) + +(define-alien-type freetype:pointer (* t)) + +(define-alien-type freetype:offset freetype:size-t) + +(define-alien-type freetype:ptr-dist freetype:size-t) + (define-alien-type nil (enum nil (:mod-err-base #.#x000) (:mod-err-autohint #.#x100) (:mod-err-cache #.#x200) (:mod-err-cff #.#x300) (:mod-err-cid #.#x400) (:mod-err-pcf #.#x500) (:mod-err-psaux #.#x600) (:mod-err-psnames #.#x700) (:mod-err-raster #.#x800) @@ -118,7 +165,10 @@ (struct freetype::memory-rec- (freetype:user (* t)) (freetype:alloc freetype:alloc-func) (freetype:free freetype:free-func) (freetype:realloc freetype:realloc-func))) -(define-alien-type freetype:stream-desc (union freetype::stream-desc- (freetype:value (signed 32)) (freetype:pointer (* t)))) +(define-alien-type freetype:stream-desc + (union freetype::stream-desc- + (freetype:value long) + (freetype:pointer (* t)))) (define-alien-type freetype:stream-io (* t)) @@ -127,8 +177,8 @@ (define-alien-type nil (struct freetype::stream-rec- (freetype:base (* (unsigned 8))) - (freetype:size (unsigned 32)) - (freetype:pos (unsigned 32)) + (freetype:size freetype:ulong) + (freetype:pos freetype:ulong) (freetype:descriptor freetype:stream-desc) (freetype:pathname freetype:stream-desc) (freetype:read freetype:stream-io) @@ -137,7 +187,7 @@ (freetype:cursor (* (unsigned 8))) (freetype:limit (* (unsigned 8))))) -(define-alien-type freetype:pos (signed 32)) +(define-alien-type freetype:pos long) (define-alien-type freetype:vector (struct freetype::vector- (freetype:x freetype:pos) (freetype:y freetype:pos))) @@ -229,52 +279,6 @@ (freetype:raster-reset freetype:raster-reset-func) (freetype:raster-set-mode freetype:raster-set-mode-func) (freetype:raster-render freetype:raster-render-func) (freetype:raster-done freetype:raster-done-func))) -(define-alien-type freetype:ptrdiff-t (signed 32)) - -(define-alien-type freetype:size-t (unsigned 32)) - -(define-alien-type freetype:wchar-t (signed 32)) - -(define-alien-type freetype:wint-t (unsigned 32)) - -(define-alien-type freetype:bool (unsigned 8)) - -(define-alien-type freetype:fword (signed 16)) - -(define-alien-type freetype:ufword (unsigned 16)) - -(define-alien-type freetype:char (signed 8)) - -(define-alien-type freetype:byte (unsigned 8)) - -(define-alien-type freetype:string (signed 8)) - -(define-alien-type freetype:short (signed 16)) - -(define-alien-type freetype:ushort (unsigned 16)) - -(define-alien-type freetype:int (signed 32)) - -(define-alien-type freetype:uint (unsigned 32)) - -(define-alien-type freetype:long (signed 32)) - -(define-alien-type freetype:ulong (unsigned 32)) - -(define-alien-type freetype:f2dot14 (signed 16)) - -(define-alien-type freetype:f26dot6 (signed 32)) - -(define-alien-type freetype:fixed (signed 32)) - -(define-alien-type freetype:error (signed 32)) - -(define-alien-type freetype:pointer (* t)) - -(define-alien-type freetype:offset freetype:size-t) - -(define-alien-type freetype:ptr-dist freetype:size-t) - (define-alien-type freetype:unit-vector (struct freetype::unit-vector- (freetype:x freetype:f2dot14) (freetype:y freetype:f2dot14))) @@ -310,7 +314,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:size-metrics @@ -347,7 +351,7 @@ (freetype:linear-vert-advance freetype:fixed) (freetype:advance freetype:vector) (freetype:format freetype:glyph-format) (freetype:bitmap freetype:bitmap) (freetype:bitmap-left freetype:int) (freetype:bitmap-top freetype:int) (freetype:outline freetype:outline) (freetype:num-subglyphs freetype:uint) (freetype:subglyphs (* freetype:sub-glyph)) - (freetype:control-data (* t)) (freetype:control-len (signed 32)) (freetype:other (* t)) + (freetype:control-data (* t)) (freetype:control-len long) (freetype:other (* t)) (freetype:internal freetype:slot-internal))) (define-alien-type freetype:glyph-slot (* freetype:glyph-slot-rec))

1 0

[mcclim-cvs] CVS update: mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 22 Aug '05

22 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv18523 Modified Files: manual.tex Log Message: Fixed the figure of the example application according to a mail from Dan Barlow in July of 2003. Date: Mon Aug 22 04:49:06 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.30 mcclim/Doc/manual.tex:1.31 --- mcclim/Doc/manual.tex:1.30 Sun Aug 14 08:20:12 2005 +++ mcclim/Doc/manual.tex Mon Aug 22 04:49:05 2005 @@ -394,7 +394,8 @@ \begin{figure} \begin{center} -\includegraphics{ex2} +\epsfxsize=5in +\epsffile{ex2.eps} \end{center} \caption{\label{figex2} View of the improved example} \end{figure}

1 0

[mcclim-cvs] CVS update: mcclim/Lisp-Dep/fix-sbcl.lisp
by crhodes＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory common-lisp.net:/tmp/cvs-serv32041/Lisp-Dep Modified Files: fix-sbcl.lisp Log Message: SBCL / OpenMCL(?) build fixes Fix the perennially annoying duplicate component error in the Scigraph defsystem (name the components by the full namestring, which should be unique) While I'm at it, fix the annoyance over static / dynamic packages: for sbcl, clim-lisp-patch and clim-mop are dynamic packages, so they shouldn't be created by DEFPACKAGE (because reevaluating the defpackage subsequently, say by recompiling stuff, then invokes undefined behaviour) Date: Fri Aug 19 23:34:43 2005 Author: crhodes Index: mcclim/Lisp-Dep/fix-sbcl.lisp diff -u mcclim/Lisp-Dep/fix-sbcl.lisp:1.8 mcclim/Lisp-Dep/fix-sbcl.lisp:1.9 --- mcclim/Lisp-Dep/fix-sbcl.lisp:1.8 Mon Feb 23 11:48:28 2004 +++ mcclim/Lisp-Dep/fix-sbcl.lisp Fri Aug 19 23:34:43 2005 @@ -2,10 +2,11 @@ (when (find-package "SB-MOP") (pushnew :sb-mop *features*))) -(defpackage #:clim-mop - (:use #+sb-mop #:sb-mop #-sb-mop #:sb-pcl) - #-sb-mop - (:shadowing-import-from #:sb-pcl #:eql-specializer-object)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:clim-mop) + (make-package '#:clim-mop :use '(#+sb-mop #:sb-mop + #-sb-mop #:sb-pcl)) + (shadowing-import 'sb-pcl::eql-specializer-object '#:clim-mop))) (eval-when (:compile-toplevel :load-toplevel :execute) (loop for sym being the symbols of :clim-mop

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd mcclim/patch.lisp
by crhodes＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv32041 Modified Files: mcclim.asd patch.lisp Log Message: SBCL / OpenMCL(?) build fixes Fix the perennially annoying duplicate component error in the Scigraph defsystem (name the components by the full namestring, which should be unique) While I'm at it, fix the annoyance over static / dynamic packages: for sbcl, clim-lisp-patch and clim-mop are dynamic packages, so they shouldn't be created by DEFPACKAGE (because reevaluating the defpackage subsequently, say by recompiling stuff, then invokes undefined behaviour) Date: Fri Aug 19 23:34:42 2005 Author: crhodes Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.5 mcclim/mcclim.asd:1.6 --- mcclim/mcclim.asd:1.5 Wed Apr 20 00:35:42 2005 +++ mcclim/mcclim.asd Fri Aug 19 23:34:41 2005 @@ -78,7 +78,7 @@ (parse-namestring c) (make-pathname :type "lisp" :defaults *clim-directory*)) - collect `(:file ,(pathname-name p) :pathname ,p)))))) + collect `(:file ,(namestring p) :pathname ,p)))))) (defsystem :clim-lisp :components Index: mcclim/patch.lisp diff -u mcclim/patch.lisp:1.4 mcclim/patch.lisp:1.5 --- mcclim/patch.lisp:1.4 Mon Nov 15 05:47:41 2004 +++ mcclim/patch.lisp Fri Aug 19 23:34:41 2005 @@ -1,6 +1,10 @@ (in-package :cl-user) -(defpackage :clim-lisp-patch - (:use) - (:export #:describe #:describe-object #:interactive-stream-p)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :clim-lisp-patch) + (make-package :clim-lisp-patch :use nil))) +(export '(clim-lisp-patch::describe + clim-lisp-patch::describe-object + clim-lisp-patch::interactive-stream-p) + :clim-lisp-patch)

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by rstrandh＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19958 Modified Files: panes.lisp Log Message: Patch to panes.lisp from Max-Gerd Retzlaff. Date: Fri Aug 19 04:20:35 2005 Author: rstrandh Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.153 mcclim/panes.lisp:1.154 --- mcclim/panes.lisp:1.153 Wed Jun 22 11:49:15 2005 +++ mcclim/panes.lisp Fri Aug 19 04:20:35 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.153 2005/06/22 09:49:15 tmoore Exp $ +;;; $Id: panes.lisp,v 1.154 2005/08/19 02:20:35 rstrandh Exp $ (in-package :clim-internals) @@ -2591,6 +2591,7 @@ #+clim-mp (unless input-buffer (clim-sys:make-process (lambda () (let ((*application-frame* frame)) + (redisplay-frame-panes frame :force-p t) (standalone-event-loop))))) (slot-value frame 'stream)))

1 0

[mcclim-cvs] CVS update: mcclim/dialog.lisp
by rstrandh＠common-lisp.net 19 Aug '05

19 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv14088 Modified Files: dialog.lisp Log Message: Patches to dialog.lisp from Max-Gerd Retzlaff. Date: Fri Aug 19 02:48:26 2005 Author: rstrandh Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.19 mcclim/dialog.lisp:1.20 --- mcclim/dialog.lisp:1.19 Fri Feb 25 15:15:17 2005 +++ mcclim/dialog.lisp Fri Aug 19 02:48:25 2005 @@ -136,6 +136,19 @@ (defvar *accepting-values-stream* nil) +(defmacro with-stream-in-own-window ((&optional (stream '*query-io*) + &rest further-streams) + &rest body) + `(let* ((,stream (open-window-stream)) + ,@(mapcar (lambda (a-stream) + (list a-stream stream)) + further-streams)) + (sleep 0.1) ;; hackhack.. some delay to "ensure" that the window-stream ist opened + (unwind-protect + (progn + ,@body) + (close ,stream)))) + (defmacro accepting-values ((&optional (stream t) &rest args @@ -144,17 +157,22 @@ align-prompts label scroll-bars x-position y-position width height command-table frame-class) &body body) - (declare (ignorable own-window exit-boxes initially-select-query-identifier + (declare (ignorable exit-boxes initially-select-query-identifier modify-initial-query resynchronize-every-pass resize-frame align-prompts label scroll-bars x-position y-position width height command-table frame-class)) (setq stream (stream-designator-symbol stream '*standard-input*)) (with-gensyms (accepting-values-continuation) - `(flet ((,accepting-values-continuation (,stream) - ,@body)) - (invoke-accepting-values ,stream - #',accepting-values-continuation - ,@args)))) + (let ((return-form + `(flet ((,accepting-values-continuation (,stream) + ,@body)) + (invoke-accepting-values ,stream + #',accepting-values-continuation + ,@args)) + )) + (if own-window + `(with-stream-in-own-window (,stream *standard-input* *standard-output*) ,return-form) + return-form)))) (defun invoke-accepting-values (stream body @@ -167,7 +185,10 @@ (frame-class 'accept-values)) (declare (ignore own-window exit-boxes modify-initial-query resize-frame label scroll-bars x-position y-position - width height frame-class)) + width height frame-class)) + (when (and align-prompts ;; t means the same as :right + (not (eq align-prompts :left))) + (setf align-prompts :right)) (multiple-value-bind (cx cy) (stream-cursor-position stream) (let* ((*accepting-values-stream* (make-instance 'accepting-values-stream @@ -224,11 +245,11 @@ (fresh-line stream) (with-output-as-presentation (stream nil 'exit-button) - (format stream "Exit")) + (format stream "OK")) (write-char #\space stream) (with-output-as-presentation (stream nil 'abort-button) - (format stream "Abort")) + (format stream "Cancel")) (terpri stream))) (defmethod stream-accept ((stream accepting-values-stream) type

1 0

[mcclim-cvs] CVS update: mcclim/design.lisp mcclim/ports.lisp
by rstrandh＠common-lisp.net 18 Aug '05

18 Aug '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26220 Modified Files: design.lisp ports.lisp Log Message: Removed a few compiler warnings. Date: Thu Aug 18 21:58:18 2005 Author: rstrandh Index: mcclim/design.lisp diff -u mcclim/design.lisp:1.23 mcclim/design.lisp:1.24 --- mcclim/design.lisp:1.23 Wed Oct 6 07:12:12 2004 +++ mcclim/design.lisp Thu Aug 18 21:58:18 2005 @@ -89,6 +89,8 @@ (define-protocol-class color (design uniform-design)) +(defgeneric color-rgb (color)) + (defmethod print-object ((color color) stream) (print-unreadable-object (color stream :identity nil :type t) (multiple-value-call #'format stream "~,4F ~,4F ~,4F" (color-rgb color)))) @@ -239,6 +241,8 @@ (saturation (atan f2 f1))) (values intensity hue saturation))))) +(defgeneric color-ihs (color)) + (defmethod color-ihs ((color color)) (multiple-value-call #'rgb-to-ihs (color-rgb color))) @@ -354,6 +358,8 @@ (print-unreadable-object (flipper stream :identity nil :type t) (format stream "~S ~S" design1 design2)))) +(defgeneric make-flipping-ink (design1 design2)) + (defmethod make-flipping-ink ((design1 design) (design2 design)) (make-instance 'standard-flipping-ink :design1 design1 :design2 design2)) @@ -396,9 +402,13 @@ (defun make-pattern (array designs) (make-instance 'indexed-pattern :array array :designs designs)) +(defgeneric pattern-width (pattern)) + (defmethod pattern-width ((pattern indexed-pattern)) (with-slots (array) pattern (array-dimension array 1))) + +(defgeneric pattern-height (pattern)) (defmethod pattern-height ((pattern indexed-pattern)) (with-slots (array) pattern Index: mcclim/ports.lisp diff -u mcclim/ports.lisp:1.48 mcclim/ports.lisp:1.49 --- mcclim/ports.lisp:1.48 Tue Feb 22 04:14:26 2005 +++ mcclim/ports.lisp Thu Aug 18 21:58:18 2005 @@ -92,6 +92,9 @@ ;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together, ;; calling %SET-PORT-KEYBOARD-FOCUS. +(defgeneric port-keyboard-input-focus (port)) +(defgeneric (setf port-keyboard-input-focus) (focus port)) + (defmethod port-keyboard-input-focus (port) (declare (ignore port)) (when *application-frame* @@ -107,7 +110,7 @@ ;; now calls (setf keyboard-input-focus), we need something concrete the ;; backend can implement to set the focus. (defmethod %set-port-keyboard-focus (port focus &key timestamp) - (declare (ignore focus)) + (declare (ignore focus timestamp)) (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))

1 0