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

[Robert Strandh]

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv28655

Modified Files:
	commands.lisp 
Log Message:
Patch from Max-Gerd Retzlaff

Date: Thu Aug 18 06:30:11 2005
Author: rstrandh

Index: mcclim/commands.lisp
diff -u mcclim/commands.lisp:1.53 mcclim/commands.lisp:1.54
--- mcclim/commands.lisp:1.53	Wed Jun 22 13:41:35 2005
+++ mcclim/commands.lisp	Thu Aug 18 06:30:09 2005
@@ -746,30 +746,36 @@
       ;; We don't need fresh gensyms of these variables for each accept form.
       (with-gensyms (value ptype changedp)
 	`(defun ,name (,command-table ,stream ,partial-command)
-	   (destructuring-bind (,command-name , at original-args)
-	       ,partial-command
-	     (let ((,command-line-name (command-line-name-for-command
-					,command-name
-					,command-table
-					:errorp nil))
-		   ,@(mapcar #'list required-arg-names original-args))
-	       (accepting-values (,stream)
-		 (format ,stream
-			 "You are being prompted for arguments to ~S~%"
-			 ,command-line-name)
-		 ,@(loop
-		      for var in required-arg-names
-		      for original-var in original-args
-		      for parameter in required-args
-		      append `((multiple-value-bind (,value ,ptype ,changedp)
-				   ,(accept-form-for-argument-partial
-				     stream parameter var original-var)
-				 (declare (ignore ,ptype))
-				 (terpri ,stream)
-				 (when ,changedp
-				   (setq ,var ,value))))))
-	       (list ,command-name , at required-arg-names))))))))
-
+           (do ((still-missing nil t))
+               (nil)
+             (destructuring-bind (,command-name , at original-args)
+                 ,partial-command
+               (let ((,command-line-name (command-line-name-for-command
+                                          ,command-name
+                                          ,command-table
+                                          :errorp nil))
+                     ,@(mapcar #'list required-arg-names original-args))
+                 (accepting-values (,stream)
+                   (format ,stream
+                           "You are being prompted for arguments to ~S~%~%"
+                           ,command-line-name)
+                   ,@(loop
+                        for var in required-arg-names
+                        for original-var in original-args
+                        for parameter in required-args
+                        append `((multiple-value-bind (,value ,ptype ,changedp)
+                                     ,(accept-form-for-argument-partial
+                                       stream parameter var original-var)
+                                   (declare (ignore ,ptype))
+                                   (terpri ,stream)
+                                   (when ,changedp
+                                     (setq ,var ,value)))))
+                   (when still-missing
+                     (format ,stream
+                             "~&Please supply all arguments.")))
+                 (setf ,partial-command (list ,command-name , at required-arg-names))
+                 (unless (partial-command-p ,partial-command)
+                   (return ,partial-command))))))))))
 
 ;;; XXX What do to about :acceptably? Probably need to wait for Goatee "buffer
 ;;; streams" so we can insert an accept-result-extent in the buffer for
@@ -1079,7 +1085,6 @@
 				     stream
 				     (view textual-view)
 				     &key)
-  (declare (ignore acceptably for-context-type))
   (let ((command-line-name (command-line-name-for-command object command-table
 							  :errorp nil)))
     (if command-line-name