February 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/Persistent/persistent-buffer.lisp
by abakic＠common-lisp.net 25 Feb '05

25 Feb '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv20153/Persistent Modified Files: persistent-buffer.lisp Log Message: Updated persistent buffers and tests to catch up with recent changes. Date: Fri Feb 25 21:45:14 2005 Author: abakic Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.6 climacs/Persistent/persistent-buffer.lisp:1.7 --- climacs/Persistent/persistent-buffer.lisp:1.6 Sun Feb 6 17:33:52 2005 +++ climacs/Persistent/persistent-buffer.lisp Fri Feb 25 21:45:11 2005 @@ -103,8 +103,10 @@ (cursor-pos (cursor mark))) (defmethod (setf offset) (new-offset (mark p-mark-mixin)) - (assert (<= 0 new-offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset new-offset)) + (assert (<= 0 new-offset) () + (make-condition 'motion-before-beginning :offset new-offset)) + (assert (<= new-offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) () @@ -119,8 +121,10 @@ &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) - (assert (<= 0 offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-persistent-cursor :buffer (buffer mark) @@ -130,8 +134,10 @@ &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) - (assert (<= 0 offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-persistent-cursor :buffer (buffer mark) @@ -145,6 +151,26 @@ (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) +(defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) + (cond + ((or (null stick-to) (eq stick-to :left)) + (make-instance 'persistent-left-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :right) + (make-instance 'persistent-right-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + +(defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to) + (cond + ((or (null stick-to) (eq stick-to :right)) + (make-instance 'persistent-right-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :left) + (make-instance 'persistent-left-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + (defmethod size ((buffer binseq-buffer)) (binseq-length (slot-value buffer 'contents))) @@ -258,8 +284,10 @@ ;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER (defmethod insert-buffer-object ((buffer binseq-buffer) offset object) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq-insert (slot-value buffer 'contents) offset object))) @@ -286,8 +314,10 @@ (insert-buffer-sequence (buffer mark) (offset mark) sequence)) (defmethod delete-buffer-range ((buffer binseq-buffer) offset n) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq-remove* (slot-value buffer 'contents) offset n))) @@ -324,32 +354,44 @@ (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defmethod buffer-object ((buffer binseq-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (binseq-get (slot-value buffer 'contents) offset)) (defmethod (setf buffer-object) (object (buffer binseq-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (binseq-set (slot-value buffer 'contents) offset object))) (defmethod buffer-object ((buffer obinseq-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (obinseq-get (slot-value buffer 'contents) offset)) (defmethod (setf buffer-object) (object (buffer obinseq-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (obinseq-set (slot-value buffer 'contents) offset object))) (defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2) - (assert (<= 0 offset1 (size buffer)) () - (make-condition 'no-such-offset :offset offset1)) - (assert (<= 0 offset2 (size buffer)) () - (make-condition 'no-such-offset :offset offset2)) + (assert (<= 0 offset1) () + (make-condition 'offset-before-beginning :offset offset1)) + (assert (<= offset1 (size buffer)) () + (make-condition 'offset-after-end :offset offset1)) + (assert (<= 0 offset2) () + (make-condition 'offset-before-beginning :offset offset2)) + (assert (<= offset2 (size buffer)) () + (make-condition 'offset-after-end :offset offset2)) (coerce (let ((len (- offset2 offset1))) (if (> len 0)

1 0

[climacs-cvs] CVS update: climacs/base-test.lisp climacs/buffer-test.lisp
by abakic＠common-lisp.net 25 Feb '05

25 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20153 Modified Files: base-test.lisp buffer-test.lisp Log Message: Updated persistent buffers and tests to catch up with recent changes. Date: Fri Feb 25 21:45:08 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.10 climacs/base-test.lisp:1.11 --- climacs/base-test.lisp:1.10 Sat Feb 12 16:34:46 2005 +++ climacs/base-test.lisp Fri Feb 25 21:45:07 2005 @@ -8,20 +8,22 @@ (defmultitest previous-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs +climacs climacs") (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 8))) - (previous-line mark) + :buffer buffer :offset 16))) + (previous-line mark nil 2) (offset mark))) 0) (defmultitest previous-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs +climacs climacs") (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 11))) - (previous-line mark 2) + :buffer buffer :offset 19))) + (previous-line mark 2 2) (offset mark))) 2) @@ -78,22 +80,24 @@ (defmultitest next-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs +climacs climacs") (let ((mark (make-instance %%left-sticky-mark :buffer buffer :offset 6))) - (next-line mark) + (next-line mark nil 2) (offset mark))) - 14) + 22) (defmultitest next-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs +climacs climacs") (let ((mark (make-instance %%right-sticky-mark :buffer buffer :offset 3))) - (next-line mark 2) + (next-line mark 2 2) (offset mark))) - 10) + 18) (defmultitest next-line.test-3 (let ((buffer (make-instance %%buffer))) @@ -150,9 +154,10 @@ (insert-buffer-sequence buffer 0 "climacs") (let ((mark (make-instance %%left-sticky-mark :buffer buffer :offset 0))) - (open-line mark) + (open-line mark 2) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) " + climacs" 0) (defmultitest open-line.test-2 Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.16 climacs/buffer-test.lisp:1.17 --- climacs/buffer-test.lisp:1.16 Fri Feb 25 08:11:24 2005 +++ climacs/buffer-test.lisp Fri Feb 25 21:45:07 2005 @@ -55,7 +55,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (make-instance %%left-sticky-mark :buffer buffer :offset 1)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 1))) t) @@ -63,7 +63,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (make-instance %%right-sticky-mark :buffer buffer :offset 1)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 1))) t) @@ -137,7 +137,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-object buffer -1 #\a)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) t) @@ -171,7 +171,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 1 "climacs")) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 1))) t) @@ -179,7 +179,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer -1 "climacs")) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) t) @@ -225,7 +225,7 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer -1 0)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) t) @@ -234,7 +234,7 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 6 2)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 8))) t) @@ -482,7 +482,7 @@ (let ((m (make-instance %%left-sticky-mark :buffer buffer :offset 4))) (setf (offset m) -1))) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) t) @@ -493,7 +493,7 @@ (let ((m (make-instance %%left-sticky-mark :buffer buffer :offset 4))) (setf (offset m) 8))) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 8))) t) @@ -516,7 +516,7 @@ (m2 (clone-mark m1))) (backward-object m1 3) (region-to-sequence m1 m2))) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) t) @@ -539,7 +539,7 @@ (m2 (clone-mark m1))) (forward-object m1 3) (region-to-sequence m1 m2))) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 9))) t) @@ -554,7 +554,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (setf (buffer-object buffer 0) #\a)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::offset-after-end (c) (= (climacs-buffer::condition-offset c) 0))) t) @@ -562,7 +562,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (setf (buffer-object buffer -1) #\a)) - (climacs-buffer::no-such-offset (c) + (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) t)

1 0

[climacs-cvs] CVS update: climacs/buffer-test.lisp climacs/buffer.lisp climacs/cl-syntax.lisp
by rstrandh＠common-lisp.net 25 Feb '05

25 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8126 Modified Files: buffer-test.lisp buffer.lisp cl-syntax.lisp Log Message: Changed the contract of clone mark so that the optional argument is either :left or :right forcing the return value to be a left-sticky-mark and a right-sticky-mark respectively. Altered the two calls (in test code) that actually used the optional argument to pass the right thing. Modified the implementation of clone-mark to use constant symbols for the class to instantiate, and made two methods so that the type of the argument will be known statically. Still needed an explicit test for the optional argument, but that is still much faster than using a variable class to make-instance. Date: Fri Feb 25 08:11:25 2005 Author: rstrandh Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.15 climacs/buffer-test.lisp:1.16 --- climacs/buffer-test.lisp:1.15 Thu Feb 10 01:27:07 2005 +++ climacs/buffer-test.lisp Fri Feb 25 08:11:24 2005 @@ -77,8 +77,8 @@ (high (slot-value buffer 'high-mark)) (low2 (clone-mark low)) (high2 (clone-mark high)) - (low3 (clone-mark high %%left-sticky-mark)) - (high3 (clone-mark low %%right-sticky-mark))) + (low3 (clone-mark high :left)) + (high3 (clone-mark low :right))) (and (reduce #'%all-eq (list (class-of low) (class-of low2) (class-of low3))) (reduce #'%all-eq Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.28 climacs/buffer.lisp:1.29 --- climacs/buffer.lisp:1.28 Wed Feb 23 19:15:32 2005 +++ climacs/buffer.lisp Fri Feb 25 08:11:24 2005 @@ -179,14 +179,29 @@ (setf low-mark (make-instance 'standard-left-sticky-mark :buffer buffer)) (setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer)))) -(defgeneric clone-mark (mark &optional type) - (:documentation "Clone a mark. By default (when type is NIL) the same type of mark is -returned. Otherwise type is the name of a class (subclass of the mark -class) to be used as a class of the clone.")) +(defgeneric clone-mark (mark &optional stick-to) + (:documentation "Clone a mark. By default (when stick-to is NIL) +the same type of mark is returned. Otherwise stick-to is either :left +or :right indicating whether a left-sticky or a right-sticky mark +should be created.")) -(defmethod clone-mark ((mark mark) &optional type) - (make-instance (or type (class-of mark)) - :buffer (buffer mark) :offset (offset mark))) +(defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to) + (cond ((or (null stick-to) (eq stick-to :left)) + (make-instance 'standard-left-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :right) + (make-instance 'standard-right-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + +(defmethod clone-mark ((mark standard-right-sticky-mark) &optional stick-to) + (cond ((or (null stick-to) (eq stick-to :right)) + (make-instance 'standard-right-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :left) + (make-instance 'standard-left-sticky-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) (defgeneric size (buffer) (:documentation "Return the number of objects in the buffer.")) Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.1 climacs/cl-syntax.lisp:1.2 --- climacs/cl-syntax.lisp:1.1 Mon Feb 7 16:26:41 2005 +++ climacs/cl-syntax.lisp Fri Feb 25 08:11:24 2005 @@ -171,71 +171,71 @@ (defun next-entry (scan) (let ((start-mark (clone-mark scan))) - (flet ((make-entry (type) - (return-from next-entry - (make-instance type :start-mark start-mark :end-mark (clone-mark scan)))) - (fo () (forward-object scan))) - (loop with object = (object-after scan) - until (end-of-buffer-p scan) - do (case object - (#\( (fo) (make-entry 'list-start-entry)) - (#\) (fo) (make-entry 'list-end-entry)) - (#\; (fo) (make-entry 'comment-entry)) - (#\" (fo) (make-entry 'double-quote-entry)) - (#\' (fo) (make-entry 'quote-entry)) - (#\` (fo) (make-entry 'backquote-entry)) - (#\, (fo) (make-entry 'unquote-entry)) - (#\# (fo) - (loop until (end-of-buffer-p scan) - while (member (object-after scan) - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - do (fo)) - (if (end-of-buffer-p scan) - (make-entry 'error-entry) - (case (object-after scan) - (#\# (fo) (make-entry 'label-ref-entry)) - (#\= (fo) (make-entry 'label-entry)) - (#\' (fo) (make-entry 'function-entry)) - (#\| (fo) (make-entry 'balanced-comment-entry)) - (#\+ (fo) (make-entry 'read-time-conditional-plus-entry)) - (#\- (fo) (make-entry 'read-time-conditional-minus-entry)) - (#\( (fo) (make-entry 'vector-entry)) - (#\* (fo) (make-entry 'bitvector-entry)) - (#\: (fo) (make-entry 'uninterned-symbol-entry)) - (#\. (fo) (make-entry 'read-time-evaluation-entry)) - ((#\A #\a) (fo) (make-entry 'array-entry)) - ((#\B #\b) (fo) (make-entry 'binary-entry)) - ((#\C #\c) (fo) (make-entry 'complex-entry)) - ((#\O #\o) (fo) (make-entry 'octal-entry)) - ((#\P #\p) (fo) (make-entry 'pathname-entry)) - ((#\R #\r) (fo) (make-entry 'radix-n-entry)) - ((#\S #\s) (fo) (make-entry 'structure-entry)) - ((#\X #\x) (fo) (make-entry 'hex-entry)) - (#\\ (fo) - (cond ((end-of-buffer-p scan) - (make-entry 'error-entry)) - ((not (constituentp (object-after scan))) - (fo) - (make-entry 'character-entry)) - (t - (fo) - (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-entry 'character-entry)))) - (t (make-entry 'error-entry))))) - (t (cond ((whitespacep object) - (loop until (end-of-buffer-p scan) - while (whitespacep (object-after scan)) - do (fo)) - (make-entry 'whitespace-entry)) - ((constituentp object) - (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-entry 'token-entry)) - (t - (fo) (make-entry 'error-entry))))))))) + (flet ((fo () (forward-object scan))) + (macrolet ((make-entry (type) + `(return-from next-entry + (make-instance ,type :start-mark start-mark :end-mark (clone-mark scan))))) + (loop with object = (object-after scan) + until (end-of-buffer-p scan) + do (case object + (#\( (fo) (make-entry 'list-start-entry)) + (#\) (fo) (make-entry 'list-end-entry)) + (#\; (fo) (make-entry 'comment-entry)) + (#\" (fo) (make-entry 'double-quote-entry)) + (#\' (fo) (make-entry 'quote-entry)) + (#\` (fo) (make-entry 'backquote-entry)) + (#\, (fo) (make-entry 'unquote-entry)) + (#\# (fo) + (loop until (end-of-buffer-p scan) + while (member (object-after scan) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + do (fo)) + (if (end-of-buffer-p scan) + (make-entry 'error-entry) + (case (object-after scan) + (#\# (fo) (make-entry 'label-ref-entry)) + (#\= (fo) (make-entry 'label-entry)) + (#\' (fo) (make-entry 'function-entry)) + (#\| (fo) (make-entry 'balanced-comment-entry)) + (#\+ (fo) (make-entry 'read-time-conditional-plus-entry)) + (#\- (fo) (make-entry 'read-time-conditional-minus-entry)) + (#\( (fo) (make-entry 'vector-entry)) + (#\* (fo) (make-entry 'bitvector-entry)) + (#\: (fo) (make-entry 'uninterned-symbol-entry)) + (#\. (fo) (make-entry 'read-time-evaluation-entry)) + ((#\A #\a) (fo) (make-entry 'array-entry)) + ((#\B #\b) (fo) (make-entry 'binary-entry)) + ((#\C #\c) (fo) (make-entry 'complex-entry)) + ((#\O #\o) (fo) (make-entry 'octal-entry)) + ((#\P #\p) (fo) (make-entry 'pathname-entry)) + ((#\R #\r) (fo) (make-entry 'radix-n-entry)) + ((#\S #\s) (fo) (make-entry 'structure-entry)) + ((#\X #\x) (fo) (make-entry 'hex-entry)) + (#\\ (fo) + (cond ((end-of-buffer-p scan) + (make-entry 'error-entry)) + ((not (constituentp (object-after scan))) + (fo) + (make-entry 'character-entry)) + (t + (fo) + (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-entry 'character-entry)))) + (t (make-entry 'error-entry))))) + (t (cond ((whitespacep object) + (loop until (end-of-buffer-p scan) + while (whitespacep (object-after scan)) + do (fo)) + (make-entry 'whitespace-entry)) + ((constituentp object) + (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-entry 'token-entry)) + (t + (fo) (make-entry 'error-entry)))))))))) (defmethod update-syntax (buffer (syntax cl-syntax)) (let ((low-mark (low-mark buffer))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 24 Feb '05

24 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28328 Modified Files: gui.lisp Log Message: Many commands now capture their own error situations and give reasonable error messages in the minibuffer. Date: Thu Feb 24 09:30:30 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.123 climacs/gui.lisp:1.124 --- climacs/gui.lisp:1.123 Wed Feb 23 19:15:32 2005 +++ climacs/gui.lisp Thu Feb 24 09:30:28 2005 @@ -603,7 +603,10 @@ (setf (offset point) (offset point-backup))))) (define-command com-extended-command () - (let ((item (accept 'command :prompt "Extended Command"))) + (let ((item (handler-case (accept 'command :prompt "Extended Command") + (error () (progn (beep) + (display-message "No such command") + (return-from com-extended-command nil)))))) (execute-frame-command *application-frame* item))) (eval-when (:compile-toplevel :load-toplevel) @@ -729,12 +732,18 @@ (define-named-command (com-quit) () (loop for buffer in (buffers *application-frame*) when (and (needs-saving buffer) - (accept 'boolean - :prompt (format nil "Save buffer: ~a ?" (name buffer)))) + (handler-case (accept 'boolean + :prompt (format nil "Save buffer: ~a ?" (name buffer))) + (error () (progn (beep) + (display-message "Invalid answer") + (return-from com-quit nil))))) do (save-buffer buffer)) (when (or (notany #'needs-saving (buffers *application-frame*)) - (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")) + (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") + (error () (progn (beep) + (display-message "Invalid answer") + (return-from com-quit nil))))) (frame-exit *application-frame*))) (define-named-command com-write-buffer () @@ -776,7 +785,10 @@ (with-slots (buffers) *application-frame* (let ((buffer (buffer (current-window)))) (when (and (needs-saving buffer) - (accept 'boolean :prompt "Save buffer first?")) + (handler-case (accept 'boolean :prompt "Save buffer first?") + (error () (progn (beep) + (display-message "Invalid answer") + (return-from com-kill-buffer nil))))) (com-save-buffer)) (setf buffers (remove buffer buffers)) ;; Always need one buffer. @@ -816,14 +828,20 @@ (define-named-command com-goto-position () (setf (offset (point (current-window))) - (accept 'integer :prompt "Goto Position"))) + (handler-case (accept 'integer :prompt "Goto Position") + (error () (progn (beep) + (display-message "Not a valid position") + (return-from com-goto-position nil)))))) (define-named-command com-goto-line () (loop with mark = (make-instance 'standard-right-sticky-mark ;PB :buffer (buffer (current-window))) do (end-of-line mark) until (end-of-buffer-p mark) - repeat (accept 'integer :prompt "Goto Line") + repeat (handler-case (accept 'integer :prompt "Goto Line") + (error () (progn (beep) + (display-message "Not a valid line number") + (return-from com-goto-line nil)))) do (incf (offset mark)) (end-of-line mark) finally (beginning-of-line mark) @@ -846,7 +864,10 @@ (let* ((pane (current-window)) (buffer (buffer pane))) (setf (syntax buffer) - (make-instance (accept 'syntax :prompt "Set Syntax") + (make-instance (or (accept 'syntax :prompt "Set Syntax") + (progn (beep) + (display-message "No such syntax") + (return-from com-set-syntax nil))) :buffer buffer)) (setf (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)))) @@ -1021,7 +1042,10 @@ (insert-sequence point (kill-ring-yank *kill-ring*)))) (define-named-command com-resize-kill-ring () - (let ((size (accept 'integer :prompt "New kill ring size"))) + (let ((size (handler-case (accept 'integer :prompt "New kill ring size") + (error () (progn (beep) + (display-message "Not a valid kill ring size") + (return-from com-resize-kill-ring nil)))))) (setf (kill-ring-max-size *kill-ring*) size))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1141,10 +1165,16 @@ (/= (offset mark) offset-before)))) (define-named-command com-query-replace () - (let* ((string1 (accept 'string :prompt "Query replace")) - (string2 (accept 'string - :prompt (format nil "Query replace ~A with" - string1))) + (let* ((string1 (handler-case (accept 'string :prompt "Query replace") + (error () (progn (beep) + (display-message "Empty string") + (return-from com-query-replace nil))))) + (string2 (handler-case (accept 'string + :prompt (format nil "Query replace ~A with" + string1)) + (error () (progn (beep) + (display-message "Empty string") + (return-from com-query-replace nil))))) (pane (current-window)) (point (point pane))) (when (query-replace-find-next-match point string1) @@ -1264,8 +1294,15 @@ (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))))) + (string (handler-case (accept 'string :prompt "Eval") + (error () (progn (beep) + (display-message "Empty string") + (return-from com-eval-expression nil))))) + (result (format nil "~a" + (handler-case (eval (read-from-string string)) + (error (condition) (progn (beep) + (display-message "~a" condition) + (return-from com-eval-expression nil))))))) (if insertp (insert-sequence (point (current-window)) result) (display-message result))))

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 23 Feb '05

23 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13301 Modified Files: buffer.lisp gui.lisp packages.lisp Log Message: Implemented new conditions according to proposal on the devel list. Date: Wed Feb 23 19:15:32 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.27 climacs/buffer.lisp:1.28 --- climacs/buffer.lisp:1.27 Sat Feb 5 21:59:50 2005 +++ climacs/buffer.lisp Wed Feb 23 19:15:32 2005 @@ -81,9 +81,55 @@ (defmethod offset ((mark mark-mixin)) (cursor-pos (cursor mark))) +(define-condition no-such-offset (simple-error) + ((offset :reader condition-offset :initarg :offset)) + (:report (lambda (condition stream) + (format stream "No such offset: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to access buffer contents that is before the beginning or after +the end of the buffer.")) + +(define-condition offset-before-beginning (no-such-offset) + () + (:report (lambda (condition stream) + (format stream "Offset before beginning: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to access buffer contents that is before the beginning of the buffer.")) + +(define-condition offset-after-end (no-such-offset) + () + (:report (lambda (condition stream) + (format stream "Offset after end: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to access buffer contents that is after the end of the buffer.")) + +(define-condition invalid-motion (simple-error) + ((offset :reader condition-offset :initarg :offset)) + (:report (lambda (condition stream) + (format stream "Invalid motion to offset: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to move a mark before the beginning or after the end of the +buffer.")) + +(define-condition motion-before-beginning (invalid-motion) + () + (:report (lambda (condition stream) + (format stream "Motion before beginning: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to move a mark before the beginning of the buffer.")) + +(define-condition motion-after-end (invalid-motion) + () + (:report (lambda (condition stream) + (format stream "Motion after end: ~a" (condition-offset condition)))) + (:documentation "This condition is signaled whenever an attempt is +made to move a mark after the end of the buffer.")) + (defmethod (setf offset) (new-offset (mark mark-mixin)) - (assert (<= 0 new-offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset new-offset)) + (assert (<= 0 new-offset) () + (make-condition 'motion-before-beginning :offset new-offset)) + (assert (<= new-offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defgeneric backward-object (mark &optional count)) @@ -105,8 +151,10 @@ (defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) - (assert (<= 0 offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) @@ -115,8 +163,10 @@ (defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) - (assert (<= 0 offset (size (buffer mark))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) @@ -138,13 +188,6 @@ (make-instance (or type (class-of mark)) :buffer (buffer mark) :offset (offset mark))) -(define-condition no-such-offset (simple-error) - ((offset :reader condition-offset :initarg :offset)) - (:report (lambda (condition stream) - (format stream "No such offset: ~a" (condition-offset condition)))) - (:documentation "This condition is signaled whenever an attempt is made at an operation -that is before the beginning or after the end of the buffer.")) - (defgeneric size (buffer) (:documentation "Return the number of objects in the buffer.")) @@ -348,8 +391,10 @@ offset will be positioned after the inserted object.")) (defmethod insert-buffer-object ((buffer standard-buffer) offset object) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (insert* (slot-value buffer 'contents) offset object)) (defgeneric insert-buffer-sequence (buffer offset sequence) @@ -380,8 +425,10 @@ no-such-offset condition is signaled.")) (defmethod delete-buffer-range ((buffer standard-buffer) offset n) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (loop repeat n do (delete* (slot-value buffer 'contents) offset))) @@ -427,8 +474,10 @@ the size of the buffer, a no-such-offset condition is signaled.")) (defmethod buffer-object ((buffer standard-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (element* (slot-value buffer 'contents) offset)) (defgeneric (setf buffer-object) (object buffer offset) @@ -437,8 +486,10 @@ the size of the buffer, a no-such-offset condition is signaled.")) (defmethod (setf buffer-object) (object (buffer standard-buffer) offset) - (assert (<= 0 offset (1- (size buffer))) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) (setf (element* (slot-value buffer 'contents) offset) object)) (defgeneric buffer-sequence (buffer offset1 offset2) @@ -449,10 +500,14 @@ offset1, an empty sequence will be returned.")) (defmethod buffer-sequence ((buffer standard-buffer) offset1 offset2) - (assert (<= 0 offset1 (size buffer)) () - (make-condition 'no-such-offset :offset offset1)) - (assert (<= 0 offset2 (size buffer)) () - (make-condition 'no-such-offset :offset offset2)) + (assert (<= 0 offset1) () + (make-condition 'offset-before-beginning :offset offset1)) + (assert (<= offset1 (size buffer)) () + (make-condition 'offset-after-end :offset offset1)) + (assert (<= 0 offset2) () + (make-condition 'offset-before-beginning :offset offset2)) + (assert (<= offset2 (size buffer)) () + (make-condition 'offset-after-end :offset offset2)) (if (< offset1 offset2) (loop with result = (make-array (- offset2 offset1)) for offset from offset1 below offset2 Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.122 climacs/gui.lisp:1.123 --- climacs/gui.lisp:1.122 Wed Feb 23 07:13:09 2005 +++ climacs/gui.lisp Wed Feb 23 19:15:32 2005 @@ -263,9 +263,14 @@ (flet ((do-command (command) (handler-case (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) + (offset-before-beginning () + (beep) (display-message "Beginning of buffer")) + (offset-after-end () + (beep) (display-message "End of buffer")) + (motion-before-beginning () + (beep) (display-message "Beginning of buffer")) + (motion-after-end () + (beep) (display-message "End of buffer"))) (setf (previous-command *standard-output*) (if (consp command) (car command) @@ -314,8 +319,7 @@ (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym)) (item (gensym)) - (command (gensym)) - (condition (gensym))) + (command (gensym))) `(progn (redisplay-frame-panes *application-frame*) (loop while ,loop-condition @@ -329,9 +333,14 @@ (handler-case (execute-frame-command *application-frame* ,command) - (error (,condition) - (beep) - (format *error-output* "~a~%" ,condition))))) + (offset-before-beginning () + (beep) (display-message "Beginning of buffer")) + (offset-after-end () + (beep) (display-message "End of buffer")) + (motion-before-beginning () + (beep) (display-message "Beginning of buffer")) + (motion-after-end () + (beep) (display-message "End of buffer"))))) (t (unread-gesture ,gesture) ,@end-clauses)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.49 climacs/packages.lisp:1.50 --- climacs/packages.lisp:1.49 Sat Feb 12 16:34:46 2005 +++ climacs/packages.lisp Wed Feb 23 19:15:32 2005 @@ -27,7 +27,10 @@ (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark - #:clone-mark #:no-such-offset #:size #:number-of-lines + #:clone-mark + #:no-such-offset #:offset-before-beginning #:offset-after-end + #:invalid-motion #:motion-before-beginning #:motion-after-end + #:size #:number-of-lines #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>= #:forward-object #:backward-object #:beginning-of-buffer #:end-of-buffer

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 23 Feb '05

23 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5057 Modified Files: gui.lisp Log Message: Fixed a problem introduced by a recent change to the command loop, where the numeric argument flag was not replaced in commands. Date: Wed Feb 23 07:13:09 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.121 climacs/gui.lisp:1.122 --- climacs/gui.lisp:1.121 Tue Feb 22 12:01:38 2005 +++ climacs/gui.lisp Wed Feb 23 07:13:09 2005 @@ -285,20 +285,22 @@ (object) (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)) - (do-command command) - (return))) - (t nil)))) + 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)) + (do-command command) + (return))) + (t nil))))) (update-climacs)) (t (do-command object)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by crhodes＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6793 Modified Files: gui.lisp Log Message: Implement, basically from Tim Moore, a command input context for the climacs top level. (This allows presentation-to-command translators to be clickable) Date: Tue Feb 22 12:01:42 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.120 climacs/gui.lisp:1.121 --- climacs/gui.lisp:1.120 Tue Feb 22 09:29:03 2005 +++ climacs/gui.lisp Tue Feb 22 12:01:38 2005 @@ -249,57 +249,65 @@ (substitute numargp *numeric-argument-p* command :test #'eq)) (defun climacs-top-level (frame &key - command-parser command-unparser - partial-command-parser prompt) + command-parser command-unparser + partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (with-slots (windows) frame - (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) - (push (buffer (car windows)) (buffers frame)) - (let ((*standard-output* (car windows)) - (*standard-input* (find-pane-named frame 'int)) - (*print-pretty* nil) - (*abort-gestures* '((:keyboard #\g 512)))) - (redisplay-frame-panes frame :force-p t) - (loop (handler-case - (loop for gestures = '() - 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)))) - (abort-gesture () (display-message "Quit"))) - (beep) - (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)))))) + (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) + (push (buffer (car windows)) (buffers frame)) + (let ((*standard-output* (car windows)) + (*standard-input* (find-pane-named frame 'int)) + (*print-pretty* nil) + (*abort-gestures* '((:keyboard #\g 512)))) + (redisplay-frame-panes frame :force-p t) + (flet ((do-command (command) + (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))) + (update-climacs () + (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)))) + (loop + for maybe-error = t + do (handler-case + (with-input-context ('(command + :command-table 'global-climacs-table)) + (object) + (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)) + (do-command command) + (return))) + (t nil)))) + (update-climacs)) + (t + (do-command object) + (setq maybe-error nil))) + (abort-gesture () + (display-message "Quit"))) + (when maybe-error + (beep)) + (update-climacs)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym))

1 0

[climacs-cvs] CVS update: climacs/README
by crhodes＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6633 Modified Files: README Log Message: Minor textual changes. More major ones are probably necessary. Date: Tue Feb 22 12:00:34 2005 Author: crhodes Index: climacs/README diff -u climacs/README:1.1 climacs/README:1.2 --- climacs/README:1.1 Wed Dec 22 15:43:18 2004 +++ climacs/README Tue Feb 22 12:00:33 2005 @@ -28,7 +28,10 @@ How to contribute ----------------- -[fill this in when we have a cl.net project] +Discussion happens on the mailing lists accessible from +<URL:http://common-lisp.net/project/climacs/>; arcives are likewise +accessible. Contributions to make the framework and the editor a +nicer environment are actively sought. What to work on --------------- @@ -64,4 +67,4 @@ Installation ------------ -To install Climacs, se the INSTALL file. +To install Climacs, see the INSTALL file.

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30769 Modified Files: gui.lisp Log Message: Give the user a message after C-g. Date: Tue Feb 22 09:29:03 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.119 climacs/gui.lisp:1.120 --- climacs/gui.lisp:1.119 Tue Feb 22 08:29:08 2005 +++ climacs/gui.lisp Tue Feb 22 09:29:03 2005 @@ -292,7 +292,7 @@ (when (null (remaining-keys *application-frame*)) (setf (executingp *application-frame*) nil) (redisplay-frame-panes frame)))) - (abort-gesture () nil)) + (abort-gesture () (display-message "Quit"))) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27192 Modified Files: gui.lisp Log Message: C-g now aborts extended commands. Date: Tue Feb 22 08:29:09 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.118 climacs/gui.lisp:1.119 --- climacs/gui.lisp:1.118 Mon Feb 21 13:51:55 2005 +++ climacs/gui.lisp Tue Feb 22 08:29:08 2005 @@ -176,8 +176,6 @@ (return-from climacs-read-gesture (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) - when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME - do (throw 'outer-loop nil) until (or (characterp gesture) (and (typep gesture 'keyboard-event) (or (keyboard-event-character gesture) @@ -260,40 +258,41 @@ (let ((*standard-output* (car windows)) (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) - (*abort-gestures* nil)) + (*abort-gestures* '((:keyboard #\g 512)))) (redisplay-frame-panes frame :force-p t) - (loop (catch 'outer-loop - (loop for gestures = '() - 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))))) + (loop (handler-case + (loop for gestures = '() + 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)))) + (abort-gesture () nil)) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer)

1 0