[mcclim-cvs] CVS mcclim

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv14196

Modified Files:
	builtin-commands.lisp 
Log Message:
Add more user-friendly `accept' presentation method for expressions on
interactive streams.


--- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp	2006/08/05 19:54:31	1.23
+++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp	2006/09/13 10:44:15	1.24
@@ -329,6 +329,66 @@
 	       (unread-char c stream))
 	     (return (values object ptype))))))
 
+(define-presentation-method accept ((type expression)
+                                    (stream input-editing-stream)
+                                    (view textual-view)
+				    &key)
+			    ;; This method is specialized to
+			    ;; input-editing-streams and has thus been
+			    ;; made slightly more tolerant of input
+			    ;; errors. It is slightly hacky, but seems
+			    ;; to work fine.
+			    (let* ((object nil)
+	 (ptype nil))
+    (if (and #-openmcl nil subform-read)
+	(multiple-value-bind (val valid)
+	    (funcall *sys-%read-list-expression* stream *dot-ok* *termch*)
+	  (if valid
+	      (setq object val)
+	      (return-from accept (values nil 'list-terminator))))
+	;; We don't want activation gestures like :return causing an
+	;; eof while reading a form. Also, we don't want spaces within
+	;; forms or strings causing a premature return either!
+	(with-delimiter-gestures (nil :override t)
+	  (with-activation-gestures (nil :override t)
+            (setq object
+                  ;; We loop in our accept of user input, if a reader
+                  ;; error is signalled, we merely ignore it and ask
+                  ;; for more input. This is so a single malplaced #\(
+                  ;; or #\, won't throw up a debugger with a
+                  ;; READER-ERROR and remove whatever the user wrote
+                  ;; to the stream.
+                  (loop for potential-object =
+                       (handler-case (funcall
+                                      (if preserve-whitespace
+                                          *sys-read-preserving-whitespace*
+                                          *sys-read*)
+                                      stream
+                                      *eof-error-p*
+                                      *eof-value*
+                                      *recursivep*)
+                         #+sbcl(sb-kernel:reader-package-error (e)
+                                 (progn
+                                   ;; Resignal the error.
+                                   (error e)))
+                         ((and reader-error) (e)
+                           (declare (ignore e))
+                           nil))
+                       unless (null potential-object)
+                       return potential-object)))))
+    (setq ptype (presentation-type-of object))
+    (unless (presentation-subtypep ptype 'expression)
+      (setq ptype 'expression))
+    (if (or subform-read auto-activate)
+	(values object ptype)
+	(loop
+	   for c = (read-char stream)
+	   until (or (activation-gesture-p c) (delimiter-gesture-p c))
+	   finally
+	     (when (delimiter-gesture-p c)
+	       (unread-char c stream))
+	     (return (values object ptype))))))
+
 (with-system-redefinition-allowed
 (defun read (&optional (stream *standard-input*)
 	     (eof-error-p t)