[mcclim-cvs] CVS update: mcclim/builtin-commands.lisp mcclim/commands.lisp mcclim/input-editing.lisp mcclim/panes.lisp mcclim/presentation-defs.lisp
Timothy Moore
tmoore at common-lisp.net
Wed Jun 22 09:49:17 UTC 2005
Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv15930
Modified Files:
builtin-commands.lisp commands.lisp input-editing.lisp
panes.lisp presentation-defs.lisp
Log Message:
Added some improvements to accept-from-string so that random accept
methods and default processing are more likely to work with it.
Added a null command and null-command presentation type so that the
REPL doesn't print something obnoxious when the user enters an empty
command.
Some fixes to default processing.
Date: Wed Jun 22 11:49:16 2005
Author: tmoore
Index: mcclim/builtin-commands.lisp
diff -u mcclim/builtin-commands.lisp:1.18 mcclim/builtin-commands.lisp:1.19
--- mcclim/builtin-commands.lisp:1.18 Sat Jan 22 09:42:40 2005
+++ mcclim/builtin-commands.lisp Wed Jun 22 11:49:15 2005
@@ -24,6 +24,10 @@
;;; Global help command
+(define-command (com-null-command :command-table global-command-table :name nil)
+ ()
+ nil)
+
(define-command (com-help :command-table global-command-table :name "Help")
((kind '(completion (("Keyboard" keyboard) ("Commands" commands))
:value-key cadr)
Index: mcclim/commands.lisp
diff -u mcclim/commands.lisp:1.51 mcclim/commands.lisp:1.52
--- mcclim/commands.lisp:1.51 Mon Jan 24 10:36:00 2005
+++ mcclim/commands.lisp Wed Jun 22 11:49:15 2005
@@ -1216,6 +1216,23 @@
(position *unsupplied-argument-marker* command)))
(t (values command type)))))
+;;; A presentation type for empty input at the command line; something for
+;;; read-command to supply as a default. The command is defined in
+;;; builtin-commands.lisp.
+
+(define-presentation-type null-command
+ ()
+ :inherit-from '(command :command-table global-command-table))
+
+(define-presentation-method presentation-typep (object (type null-command))
+ (and (consp object) (eq (car object) 'com-null-command)))
+
+(define-presentation-method present
+ (object (type null-command) stream (view textual-view) &key)
+ (declare (ignore object stream view)))
+
+(defparameter +null-command+ '(com-null-command))
+
(defclass presentation-command-translator (presentation-translator)
()
(:documentation "Wraps the tester function with a test that
@@ -1308,16 +1325,20 @@
((or (typep stream 'interactor-pane)
(typep stream 'input-editing-stream))
(handler-case
- (let ((command (accept `(command :command-table ,command-table)
- :stream stream
- :prompt nil)))
- (if (partial-command-p command)
- (progn
- (beep)
- (format *query-io* "~&Argument ~D not supplied.~&"
- (position *unsupplied-argument-marker* command))
- nil)
- command))
+ (multiple-value-bind (command ptype)
+ (accept `(command :command-table ,command-table)
+ :stream stream
+ :prompt nil
+ :default +null-command+
+ :default-type 'null-command)
+ (cond ((eq ptype 'null-command)
+ nil)
+ ((partial-command-p command)
+ (beep)
+ (format *query-io* "~&Argument ~D not supplied.~&"
+ (position *unsupplied-argument-marker* command))
+ nil)
+ (t command)))
((or simple-parse-error input-not-of-required-type) (c)
(beep)
(fresh-line *query-io*)
Index: mcclim/input-editing.lisp
diff -u mcclim/input-editing.lisp:1.46 mcclim/input-editing.lisp:1.47
--- mcclim/input-editing.lisp:1.46 Sun Feb 27 01:06:27 2005
+++ mcclim/input-editing.lisp Wed Jun 22 11:49:15 2005
@@ -869,7 +869,8 @@
;;; not.
;;; XXX Actually, it would be a violation of the `accept' protocol to consume
;;; the gesture, but who knows what random accept methods are doing.
-(defun empty-input-p (stream begin-scan-pointer completion-gestures)
+(defun empty-input-p
+ (stream begin-scan-pointer activation-gestures delimiter-gestures)
(let ((scan-pointer (stream-scan-pointer stream))
(fill-pointer (fill-pointer (stream-input-buffer stream))))
;; activated?
@@ -881,7 +882,8 @@
(let ((gesture (aref (stream-input-buffer stream)
begin-scan-pointer)))
(and (characterp gesture)
- (gesture-match gesture completion-gestures))))
+ (or (gesture-match gesture activation-gestures)
+ (gesture-match gesture delimiter-gestures)))))
(t nil))))
;;; The control flow in here might be a bit confusing. The handler catches
@@ -900,13 +902,15 @@
(unless (input-editing-stream-p stream)
(return-from invoke-handle-empty-input (funcall input-continuation)))
(let ((begin-scan-pointer (stream-scan-pointer stream))
- (completion-gestures *completion-gestures*))
+ (activation-gestures *activation-gestures*)
+ (delimiter-gestures *delimiter-gestures*))
(block empty-input
(handler-bind (((or simple-parse-error empty-input-condition)
#'(lambda (c)
(when (empty-input-p stream
begin-scan-pointer
- completion-gestures)
+ activation-gestures
+ delimiter-gestures)
(if (typep c 'empty-input-condition)
(signal c)
(signal 'empty-input-condition :stream stream))
@@ -914,4 +918,5 @@
(return-from empty-input nil)))))
(return-from invoke-handle-empty-input (funcall input-continuation))))
(funcall handler-continuation)))
+
Index: mcclim/panes.lisp
diff -u mcclim/panes.lisp:1.152 mcclim/panes.lisp:1.153
--- mcclim/panes.lisp:1.152 Mon Mar 14 23:03:05 2005
+++ mcclim/panes.lisp Wed Jun 22 11:49:15 2005
@@ -27,7 +27,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; $Id: panes.lisp,v 1.152 2005/03/14 22:03:05 tmoore Exp $
+;;; $Id: panes.lisp,v 1.153 2005/06/22 09:49:15 tmoore Exp $
(in-package :clim-internals)
@@ -2518,7 +2518,9 @@
(defmethod close ((stream window-stream)
&key abort)
(declare (ignore abort))
- (disable-frame (pane-frame stream))
+ (let ((frame (pane-frame stream)))
+ (when frame
+ (disown-frame (frame-manager frame) frame)))
(call-next-method))
(define-application-frame a-window-stream (standard-encapsulating-stream
Index: mcclim/presentation-defs.lisp
diff -u mcclim/presentation-defs.lisp:1.43 mcclim/presentation-defs.lisp:1.44
--- mcclim/presentation-defs.lisp:1.43 Fri Feb 25 15:15:17 2005
+++ mcclim/presentation-defs.lisp Wed Jun 22 11:49:15 2005
@@ -927,17 +927,44 @@
(declare (ignore type view other-args))
nil)
+;;; XXX This needs work! It needs to do everything that accept does for
+;;; expanding ptypes and setting up recursive call processing
(defun accept-from-string (type string
&rest args
&key view
- default
- default-type
+ (default nil defaultp)
+ (default-type nil default-type-p)
+ activation-gestures additional-activation-gestures
+ delimiter-gestures additional-delimiter-gestures
(start 0)
(end (length string)))
- (declare (ignore view default default-type))
- (with-input-from-string (stream string :start start :end end)
- (with-keywords-removed (args (:start :end))
- (apply #'stream-accept stream type :view +textual-view+ args))))
+ (declare (ignore view activation-gestures
+ additional-activation-gestures
+ delimiter-gestures additional-delimiter-gestures))
+ (with-activation-gestures ((if additional-activations-p
+ additional-activation-gestures
+ activation-gestures)
+ :override activationsp)
+ (with-delimiter-gestures ((if additional-delimiters-p
+ additional-delimiter-gestures
+ delimiter-gestures)
+ :override delimitersp)))
+ (when (or (zerop (- end start))
+ (let ((maybe-end))))
+ (if defaultp
+ (return-from accept-from-string (values default
+ (if default-type-p
+ default-type
+ type)
+ 0))
+ (simple-parse-error "Empty string")))
+ (let ((index 0))
+ (multiple-value-bind (val ptype)
+ (with-input-from-string (stream string :start start :end end
+ :index index)
+ (with-keywords-removed (args (:start :end))
+ (apply #'stream-accept stream type :view +textual-view+ args)))
+ (values val ptype index))))
(define-presentation-generic-function %presentation-refined-position-test
presentation-refined-position-test
More information about the Mcclim-cvs
mailing list