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