[climacs-cvs] CVS update: climacs/gui.lisp

[Robert Strandh]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv9176

Modified Files:
	gui.lisp 
Log Message:
Implemented flag *numeric-argument-p* to detect whether a numeric
argument was given att all. 

Implemented eval-expression, M-:, which uses numeric-argument-p to
dentermine whether to show the result in the minibuffer or to insert
it into the buffer itself.


Date: Sat Feb 19 06:23:17 2005
Author: rstrandh

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.108 climacs/gui.lisp:1.109
--- climacs/gui.lisp:1.108	Sun Feb 13 03:52:08 2005
+++ climacs/gui.lisp	Sat Feb 19 06:23:16 2005
@@ -240,6 +240,11 @@
 			(find-if (lambda (pane) (typep pane 'scroller-pane))
 				 (sheet-children vbox)))))))
 
+(defvar *numeric-argument-p* (list nil))
+
+(defun substitute-numeric-argument-p (command numargp)
+  (substitute numargp *numeric-argument-p* command :test #'eq))
+
 (defun climacs-top-level (frame &key
 			  command-parser command-unparser 
 			  partial-command-parser prompt)
@@ -254,34 +259,36 @@
        (redisplay-frame-panes frame :force-p t)
        (loop (catch 'outer-loop
 	       (loop for gestures = '()
-		     for numarg = (read-numeric-argument :stream *standard-input*)
-		     do (loop (setf *current-gesture* (climacs-read-gesture))
-			      (setf gestures (nconc gestures (list *current-gesture*)))
-			      (let ((item (find-gestures gestures 'global-climacs-table)))
-				(cond ((not item)
-				       (beep) (return))
-				      ((eq (command-menu-item-type item) :command)
-				       (let ((command (command-menu-item-value item)))
-					 (unless (consp command)
-					   (setf command (list command)))
-					 (setf command (substitute-numeric-argument-marker command numarg))
-					 (handler-case 
-					     (execute-frame-command frame command)
-					   (error (condition)
-					     (beep)
-					     (format *error-output* "~a~%" condition)))
-					 (setf (previous-command *standard-output*)
-					       (if (consp command)
-						   (car command)
-						   command))
-					 (return)))
-				      (t nil))))
-			(let ((buffer (buffer (current-window))))
-			  (when (modified-p buffer)
-			    (setf (needs-saving buffer) t)))
-			(when (null (remaining-keys *application-frame*))
-			  (setf (executingp *application-frame*) nil)
-			  (redisplay-frame-panes frame))))
+		     do (multiple-value-bind (numarg numargp)
+			    (read-numeric-argument :stream *standard-input*)
+			  (loop (setf *current-gesture* (climacs-read-gesture))
+				(setf gestures (nconc gestures (list *current-gesture*)))
+				(let ((item (find-gestures gestures 'global-climacs-table)))
+				  (cond ((not item)
+					 (beep) (return))
+					((eq (command-menu-item-type item) :command)
+					 (let ((command (command-menu-item-value item)))
+					   (unless (consp command)
+					     (setf command (list command)))
+					   (setf command (substitute-numeric-argument-marker command numarg))
+					   (setf command (substitute-numeric-argument-p command numargp))
+					   (handler-case 
+					       (execute-frame-command frame command)
+					     (error (condition)
+					       (beep)
+					       (format *error-output* "~a~%" condition)))
+					   (setf (previous-command *standard-output*)
+						 (if (consp command)
+						     (car command)
+						     command))
+					   (return)))
+					(t nil))))
+			  (let ((buffer (buffer (current-window))))
+			    (when (modified-p buffer)
+			      (setf (needs-saving buffer) t)))
+			  (when (null (remaining-keys *application-frame*))
+			    (setf (executingp *application-frame*) nil)
+			    (redisplay-frame-panes frame)))))
 	     (beep)
 	     (let ((buffer (buffer (current-window))))
 	       (when (modified-p buffer)
@@ -1288,6 +1295,14 @@
 	 (syntax (syntax (buffer pane))))
     (display-message "~a" (forward-to-error point syntax))))
 
+(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
+  (let* ((*package* (find-package :climacs-gui))
+	 (string (accept 'string :prompt "Eval"))
+	 (result (format nil "~a" (eval (read-from-string string)))))
+    (if insertp
+	(insert-sequence (point (current-window)) result)
+	(display-message result))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 
 ;;; Global and dead-escape command tables
@@ -1317,6 +1332,7 @@
 
 (global-set-key #\Newline 'com-self-insert)
 (global-set-key #\Tab 'com-indent-line)
+(global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*))
 (global-set-key '(#\j :control) 'com-newline-and-indent)
 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))