[mcclim-cvs] CVS update: mcclim/dialog.lisp

[Robert Strandh]

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
+           , at 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)
-              , at body))
-       (invoke-accepting-values ,stream
-                                #',accepting-values-continuation
-                                , at args))))
+    (let ((return-form
+           `(flet ((,accepting-values-continuation (,stream)
+                     , at body))
+              (invoke-accepting-values ,stream
+                                       #',accepting-values-continuation
+                                       , at 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