[climacs-cvs] CVS update: climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp
Robert Strandh
rstrandh at common-lisp.net
Wed Feb 23 18:15:37 UTC 2005
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)
, at 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
More information about the Climacs-cvs
mailing list