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

[Timothy Moore]

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

Modified Files:
	commands.lisp 
Log Message:

Changes to MAKE-PARTIAL-PARSER-FUN and supporting functions. If a
command argument is unspecified and there is no default specified for
that argument, then don't pass any any :default argument to the
corresponding call to ACCEPT. Also, don't modify the variables that
hold the return values for the arguments unless the user actually
changes the value; this preserves thhe unspecified argument marker.

This fixes the bug show-cmd-table-arg.

Date: Mon Jan 24 01:36:01 2005
Author: tmoore

Index: mcclim/commands.lisp
diff -u mcclim/commands.lisp:1.50 mcclim/commands.lisp:1.51
--- mcclim/commands.lisp:1.50	Mon Dec 13 04:18:05 2004
+++ mcclim/commands.lisp	Mon Jan 24 01:36:00 2005
@@ -575,7 +575,7 @@
   "Mapping from command names to argument parsing functions.")
 
 
-(defvar *unsupplied-argument-marker* (cons nil nil))
+(defvar *unsupplied-argument-marker* (gensym "UNSUPPLIED-ARGUMENT-MARKER"))
 
 (defvar *command-name-delimiters* '(command-delimiter))
 
@@ -614,29 +614,40 @@
 					     , at args)
 					   args)))))))
 
-;;;accept for the partial command reader.  Can this be refactored to share code
-;;;with accept-form-for-argument?
-(defun accept-form-for-argument-partial (stream ptype-arg command-arg)
+;;; In the partial command reader accepting-values dialog, default
+;;; values come either from the input command arguments, if a value
+;;; was supplied, or from the default option for the command argument.
+;;;
+;;; accept for the partial command reader.  Can this be refactored to
+;;; share code with accept-form-for-argument? Probably not.
+;;;
+;;; original-command-arg is value entered by the user, or
+;;; *unsupplied-argument-marker*. command-arg is the current value for the
+;;; argument, originally bound to original-command-arg and now possibly
+;;; changed by the user.
+(defun accept-form-for-argument-partial (stream ptype-arg command-arg
+					 original-command-arg )
   (let ((accept-keys '(:default :default-type :display-default
 		       :prompt :documentation)))
-    (destructuring-bind (name ptype &rest key-args
-			 &key (mentioned-default nil mentioned-default-p)
-			 &allow-other-keys)
+    (destructuring-bind (name ptype &rest key-args)
 	ptype-arg
       (declare (ignore name))
-      (let ((accept-args-var (gensym "ACCEPT-ARGS")))
-	`(let ((,accept-args-var
-		(list ,@(loop for (key val) on key-args by #'cddr
-			      when (member key accept-keys)
-			      append `(,key ,val) into args
-			      finally (return (if mentioned-default-p
-						  `(:default ,mentioned-default
-						    , at args)
-						  args))))))
-	   (apply #'accept ,ptype :stream ,stream
-		  (if (eq ,command-arg *unsupplied-argument-marker*)
-		      ,accept-args-var
-		      (list* :default ,command-arg ,accept-args-var))))))))
+      (let ((args (loop
+		     for (key val) on key-args by #'cddr
+		     if (eq key :default)
+		       append `(:default (if (eq ,command-arg
+						 *unsupplied-argument-marker*)
+					     ,val
+					     ,command-arg))
+		     else if (member key accept-keys :test #'eq)
+		       append `(,key ,val))))
+	(if (member :default args :test #'eq)
+	    `(accept ,ptype :stream ,stream , at args)
+	    `(if (eq ,original-command-arg *unsupplied-argument-marker*)
+		 (accept ,ptype :stream ,stream , at args)
+		 (accept ,ptype :stream ,stream :default ,command-arg
+			 , at args)))))))
+
 
 (defun make-keyword (sym)
   (intern (symbol-name sym) :keyword))
@@ -730,26 +741,38 @@
 (defun make-partial-parser-fun (name required-args)
   (with-gensyms (command-table stream partial-command
 		 command-name command-line-name)
-    (let ((required-arg-names (mapcar #'car required-args)))
-      `(defun ,name (,command-table ,stream ,partial-command)
-	 (destructuring-bind (,command-name , at required-arg-names)
-	     ,partial-command
-	   (let ((,command-line-name (command-line-name-for-command
-				      ,command-name
-				      ,command-table
-				      :errorp nil)))
-	     (accepting-values (,stream)
-	       (format ,stream
-		       "You are being prompted for arguments to ~S~%"
-		       ,command-line-name)
-	       ,@(loop for var in required-arg-names
-		       for parameter in required-args
-		       append `((setq ,var
-				 ,(accept-form-for-argument-partial stream
-								    parameter
-								    var))
-				(terpri ,stream)))))
-	   (list ,command-name , at required-arg-names))))))
+    (let* ((required-arg-names (mapcar #'car required-args))
+	   (original-args (mapcar #'(lambda (arg)
+				      (gensym (format nil "~A-ORIGINAL"
+						      (symbol-name arg))))
+				  required-arg-names)))
+      ;; 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))))))))
+
 
 ;;; 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