November 2006 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Nov '06

18 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3308 Modified Files: buffer.lisp Log Message: More docstring fixes and additions. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/16 19:22:38 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/18 15:42:43 1.3 @@ -31,22 +31,31 @@ (in-package :drei-buffer) (defclass buffer () () - (:documentation "The base class for all buffers. A buffer conceptually contains a -large array of arbitrary objects. Lines of objects are separated by -newline characters. The last object of the buffer is not -necessarily a newline character.")) - -(defgeneric low-mark (buffer)) - -(defgeneric high-mark (buffer)) - -(defgeneric modified-p (buffer)) + (:documentation "The base class for all buffers. A buffer +conceptually contains a large array of arbitrary objects. Lines +of objects are separated by newline characters. The last object +of the buffer is not necessarily a newline character.")) + +(defgeneric low-mark (buffer) + (:documentation "Return the low mark of the buffer.")) + +(defgeneric high-mark (buffer) + (:documentation "Return the high mark of the buffer.")) + +(defgeneric modified-p (buffer) + (:documentation "Return true if and only if the buffer has been +modified.")) (defclass standard-buffer (buffer) ((contents :initform (make-instance 'standard-cursorchain)) - (low-mark :reader low-mark) - (high-mark :reader high-mark) - (modified :initform nil :reader modified-p)) + (low-mark :reader low-mark + :documentation "The low mark of the buffer.") + (high-mark :reader high-mark + :documentation "The high mark of the buffer.") + (modified :initform nil + :reader modified-p + :documentation "True if and only if the buffer has +been modified.")) (:documentation "The standard instantiable class for buffers.")) (defgeneric buffer (mark) @@ -72,11 +81,14 @@ (defgeneric (setf offset) (new-offset mark) (:documentation "Set the offset of the mark into the buffer. A -no-such-offset condition is signaled if the offset is less than -zero or greater than the size of the buffer.")) +motion-before-beginning condition is signaled if the offset is +less than zero. A motion-after-end condition is signaled if the +offset is greater than the size of the buffer.")) (defclass mark-mixin () - ((buffer :initarg :buffer :reader buffer) + ((buffer :initarg :buffer + :reader buffer + :documentation "The buffer that the mark is in.") (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark.")) @@ -135,12 +147,26 @@ (setf (cursor-pos (cursor mark)) new-offset)) (defgeneric backward-object (mark &optional count) - (:documentation "Move `mark' `count' objects backwards. Returns - `mark'.")) + (:documentation "Move the mark backward the number of positions +indicated by count. This function could be implemented by a +`decf' on the offset of the mark, but many buffer implementations +can implement this function much more efficiently in a different +way. A `motion-before-beginning' condition is signaled if the +resulting offset of the mark is less than zero. A +motion-after-end condition is signaled if the resulting offset of +the mark is greater than the size of the buffer. Returns +`mark'.")) (defgeneric forward-object (mark &optional count) - (:documentation "Move `mark' `count' objects forwards. Returns - `mark'")) + (:documentation "Move the mark forward the number of positions +indicated by count. This function could be implemented by an +`incf' on the offset of the mark, but many buffer implementations +can implement this function much more efficiently in a different +way. A `motion-before-beginning' condition is signaled if the +resulting offset of the mark is less than zero. A +`motion-after-end' condition is signaled if the resulting offset +of the mark is greater than the size of the buffer. Returns +`mark'.")) (defmethod forward-object ((mark mark-mixin) &optional (count 1)) (incf (offset mark) count) @@ -226,10 +252,10 @@ count (eql (buffer-object buffer offset) #\Newline))) (defgeneric mark< (mark1 mark2) - (:documentation "Return t if the offset of mark1 is strictly less than that of mark2. -An error is signaled if the two marks are not positioned in the same -buffer. It is acceptable to pass an offset in place of one of the -marks")) + (:documentation "Return T if the offset of `mark1' is strictly +less than that of `mark2'. An error is signaled if the two marks +are not positioned in the same buffer. It is acceptable to pass +an offset in place of one of the marks.")) (defmethod mark< ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -242,10 +268,10 @@ (< mark1 (offset mark2))) (defgeneric mark<= (mark1 mark2) - (:documentation "Return t if the offset of mark1 is less than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks.")) + (:documentation "Return T if the offset of `mark1' is less than +or equal to that of `mark2'. An error is signaled if the two +marks are not positioned in the same buffer. It is acceptable to +pass an offset in place of one of the marks.")) (defmethod mark<= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -258,9 +284,10 @@ (<= mark1 (offset mark2))) (defgeneric mark= (mark1 mark2) - (:documentation "Return t if the offset of mark1 is equal to that of mark2. An error - is signaled if the two marks are not positioned in the same buffer. - It is acceptable to pass an offset in place of one of the marks.")) + (:documentation "Return T if the offset of `mark1' is equal to +that of `mark2'. An error is signaled if the two marks are not +positioned in the same buffer. It is acceptable to pass an +offset in place of one of the marks.")) (defmethod mark= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -273,10 +300,10 @@ (= mark1 (offset mark2))) (defgeneric mark> (mark1 mark2) - (:documentation "Return t if the offset of mark1 is strictly greater than that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks.")) + (:documentation "Return T if the offset of `mark1' is strictly +greater than that of `mark2'. An error is signaled if the two +marks are not positioned in the same buffer. It is acceptable to +pass an offset in place of one of the marks.")) (defmethod mark> ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -289,10 +316,10 @@ (> mark1 (offset mark2))) (defgeneric mark>= (mark1 mark2) - (:documentation "Return t if the offset of mark1 is greater than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks.")) + (:documentation "Return T if the offset of `mark1' is greater +than or equal to that of `mark2'. An error is signaled if the +two marks are not positioned in the same buffer. It is +acceptable to pass an offset in place of one of the marks.")) (defmethod mark>= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -306,8 +333,8 @@ (defgeneric beginning-of-buffer (mark) (:documentation "Move the mark to the beginning of the buffer. - This is equivalent to (setf (offset mark) 0), but returns - mark.")) +This is equivalent to `(setf (offset mark) 0)', but returns +mark.")) ;; Easy way to make sure mark is always returned. (defmethod beginning-of-buffer :around (mark) @@ -319,7 +346,7 @@ (defgeneric end-of-buffer (mark) (:documentation "Move the mark to the end of the buffer and - return mark.")) +return mark.")) (defmethod end-of-buffer :around (mark) (call-next-method) @@ -329,41 +356,44 @@ (setf (offset mark) (size (buffer mark)))) (defgeneric beginning-of-buffer-p (mark) - (:documentation "Return t if the mark is at the beginning of - the buffer, nil otherwise.")) + (:documentation "Return T if the mark is at the beginning of +the buffer, nil otherwise.")) (defmethod beginning-of-buffer-p ((mark mark-mixin)) (zerop (offset mark))) (defgeneric end-of-buffer-p (mark) - (:documentation "Return t if the mark is at the end of the buffer, nil otherwise.")) + (:documentation "Return T if the mark is at the end of the +buffer, NIL otherwise.")) (defmethod end-of-buffer-p ((mark mark-mixin)) (= (offset mark) (size (buffer mark)))) (defgeneric beginning-of-line-p (mark) - (:documentation "Return t if the mark is at the beginning of the line (i.e., if the -character preceding the mark is a newline character or if the mark is -at the beginning of the buffer), nil otherwise.")) + (:documentation "Return T if the mark is at the beginning of +the line (i.e., if the character preceding the mark is a newline +character or if the mark is at the beginning of the buffer), NIL +otherwise.")) (defmethod beginning-of-line-p ((mark mark-mixin)) (or (beginning-of-buffer-p mark) (eql (object-before mark) #\Newline))) (defgeneric end-of-line-p (mark) - (:documentation "Return t if the mark is at the end of the line (i.e., if the character -following the mark is a newline character, or if the mark is at the -end of the buffer), nil otherwise.")) + (:documentation "Return T if the mark is at the end of the +line (i.e., if the character following the mark is a newline +character, or if the mark is at the end of the buffer), NIL +otherwise.")) (defmethod end-of-line-p ((mark mark-mixin)) (or (end-of-buffer-p mark) (eql (object-after mark) #\Newline))) (defgeneric beginning-of-line (mark) - (:documentation "Move the mark to the beginning of the line. The mark will be - positioned either immediately after the closest preceding newline - character, or at the beginning of the buffer if no preceding newline - character exists. Returns mark.")) + (:documentation "Move the mark to the beginning of the line. +The mark will be positioned either immediately after the closest +receding newline character, or at the beginning of the buffer if +no preceding newline character exists. Returns `mark'.")) (defmethod beginning-of-line :around (mark) (call-next-method) @@ -374,9 +404,10 @@ do (backward-object mark))) (defgeneric end-of-line (mark) - (:documentation "Move the mark to the end of the line. The mark will be positioned -either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists. Returns mark.")) + (:documentation "Move the mark to the end of the line. The mark +will be positioned either immediately before the closest +following newline character, or at the end of the buffer if no +following newline character exists. Returns `mark'.")) (defmethod end-of-line :around (mark) (call-next-method) @@ -393,17 +424,18 @@ (setf (offset mark) offset))) (defgeneric buffer-line-number (buffer offset) - (:documentation "Return the line number of the offset. Lines are numbered from zero.")) + (:documentation "Return the line number of the offset. Lines +are numbered from zero.")) (defmethod buffer-line-number ((buffer standard-buffer) (offset integer)) (loop for i from 0 below offset count (eql (buffer-object buffer i) #\Newline))) (defgeneric buffer-column-number (buffer offset) - (:documentation "Return the column number of the offset. The column number of an offset is - the number of objects between it and the preceding newline, or - between it and the beginning of the buffer if the offset is on the - first line of the buffer.")) + (:documentation "Return the column number of the offset. The +column number of an offset is the number of objects between it +and the preceding newline, or between it and the beginning of the +buffer if the offset is on the first line of the buffer.")) (defmethod buffer-column-number ((buffer standard-buffer) (offset integer)) (loop for i downfrom offset @@ -412,16 +444,17 @@ count t)) (defgeneric line-number (mark) - (:documentation "Return the line number of the mark. Lines are numbered from zero.")) + (:documentation "Return the line number of the mark. Lines are +numbered from zero.")) (defmethod line-number ((mark mark-mixin)) (buffer-line-number (buffer mark) (offset mark))) (defgeneric column-number (mark) - (:documentation "Return the column number of the mark. The column number of a mark is - the number of objects between it and the preceding newline, or - between it and the beginning of the buffer if the mark is on the - first line of the buffer.")) + (:documentation "Return the column number of the mark. The +column number of a mark is the number of objects between it and +the preceding newline, or between it and the beginning of the +buffer if the mark is on the first line of the buffer.")) (defmethod column-number ((mark mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) @@ -440,10 +473,11 @@ finally (return (column-number mark)))) (defgeneric insert-buffer-object (buffer offset object) - (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks - that are placed at the offset will remain positioned before the - inserted object. Any right-sticky marks that are placed at the - offset will be positioned after the inserted object.")) + (:documentation "Insert the object at the offset in the buffer. +Any left-sticky marks that are placed at the offset will remain +positioned before the inserted object. Any right-sticky marks +that are placed at the offset will be positioned after the +inserted object.")) (defmethod insert-buffer-object ((buffer standard-buffer) offset object) (assert (<= 0 offset) () @@ -453,31 +487,33 @@ (insert* (slot-value buffer 'contents) offset object)) (defgeneric insert-buffer-sequence (buffer offset sequence) - (:documentation "Like calling insert-buffer-object on each of the objects in the -sequence.")) + (:documentation "Like calling insert-buffer-object on each of +the objects in the sequence.")) (defmethod insert-buffer-sequence ((buffer standard-buffer) offset sequence) (insert-vector* (slot-value buffer 'contents) offset sequence)) (defgeneric insert-object (mark object) - (:documentation "Insert the object at the mark. This function simply calls -insert-buffer-object with the buffer and the position of the mark.")) + (:documentation "Insert the object at the mark. This function +simply calls insert-buffer-object with the buffer and the +position of the mark.")) (defmethod insert-object ((mark mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) (defgeneric insert-sequence (mark sequence) - (:documentation "Insert the objects in the sequence at the mark. This function simply -calls insert-buffer-sequence with the buffer and the position of the -mark.")) + (:documentation "Insert the objects in the sequence at the +mark. This function simply calls insert-buffer-sequence with the +buffer and the position of the mark.")) (defmethod insert-sequence ((mark mark-mixin) sequence) (insert-buffer-sequence (buffer mark) (offset mark) sequence)) (defgeneric delete-buffer-range (buffer offset n) - (:documentation "Delete n objects from the buffer starting at the offset. If offset - is negative or offset+n is greater than the size of the buffer, a - no-such-offset condition is signaled.")) + (:documentation "Delete n objects from the buffer starting at +the offset. If `offset' is negative or `offset'+`n' is greater +than the size of the buffer, a `no-such-offset' condition is +signaled.")) (defmethod delete-buffer-range ((buffer standard-buffer) offset n) (assert (<= 0 offset) () @@ -488,9 +524,9 @@ do (delete* (slot-value buffer 'contents) offset))) (defgeneric delete-range (mark &optional n) - (:documentation "Delete n objects after (if n > 0) or before (if n < 0) the mark. -This function eventually calls delete-buffer-range, provided that n -is not zero.")) + (:documentation "Delete `n' objects after `(if n > 0)' or +before `(if n < 0)' the mark. This function eventually calls +delete-buffer-range, provided that `n' is not zero.")) (defmethod delete-range ((mark mark-mixin) &optional (n 1)) (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n)) @@ -499,9 +535,10 @@ (defgeneric delete-region (mark1 mark2) (:documentation "Delete the objects in the buffer that are -between mark1 and mark2. An error is signaled if the two marks -are positioned in different buffers. It is acceptable to pass an -offset in place of one of the marks.")) +between `mark1' and `mark2'. An error is signaled if the two +marks are positioned in different buffers. It is acceptable to +pass an offset in place of one of the marks. This function calls +`delete-buffer-range' with the appropriate arguments.")) (defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -524,9 +561,10 @@ (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defgeneric buffer-object (buffer offset) [103 lines skipped]

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 17 Nov '06

17 Nov '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30700 Modified Files: graphics.lisp Log Message: Remove initial space in docstring as it confuses my docstring extractor. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/10/14 18:38:12 1.54 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/11/17 20:33:24 1.55 @@ -528,9 +528,10 @@ toward-x toward-y transform-glyphs ink clipping-region transformation text-style text-family text-face text-size) -" Draws a single character of filled text represented by the given element. - element is a character or other object to be translated into a font index. - The given x and y specify the left baseline position for the character." +"Draws a single character of filled text represented by the given +element. element is a character or other object to be translated +into a font index. The given x and y specify the left baseline +position for the character." (declare (ignore ink clipping-region transformation text-style text-family text-face text-size)) (with-medium-options (sheet args)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 17 Nov '06

17 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27977/Drei Modified Files: input-editor.lisp drei.lisp drei-redisplay.lisp drei-clim.lisp Log Message: Drei redisplay cleanup. Fix some annoying bugs and make the structure of the redisplay functions clearer. Also minor fixup of the Drei-customized expression acceptor and some docstring changes. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/10 01:15:58 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/17 20:18:56 1.4 @@ -76,7 +76,7 @@ (syntax (buffer (drei-instance obj)))) ;; XXX Really add it here? (stream-add-output-record stream (drei-instance obj)) - (display-drei-area (drei-instance obj))))) + (display-drei (drei-instance obj))))) (defmethod stream-insertion-pointer ((stream drei-input-editing-mixin)) @@ -202,7 +202,7 @@ (delete-region begin-mark (stream-scan-pointer stream)) (insert-sequence begin-mark new-contents)) (update-syntax (buffer drei) (syntax (buffer drei))) - (display-drei-area drei) + (display-drei drei) (when (or rescan (not equal)) (queue-rescan stream))))) @@ -387,7 +387,7 @@ (when was-directly-processing (display-message "Aborted")))))) ;; Will also take care of redisplaying minibuffer. - (display-drei (pane-frame (editor-pane drei)) drei) + (display-drei drei) (let ((first-mismatch (mismatch before (stream-input-buffer stream)))) (cond ((null first-mismatch) ;; No change actually took place, even though IP may @@ -493,7 +493,7 @@ ;; Since everything inserted with this method is noise strings, we ;; do not bother to modify the scan pointer or queue rescans. (update-syntax (buffer drei) (syntax (buffer drei))) - (display-drei-area drei))) + (display-drei drei))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -591,12 +591,15 @@ for gesture = (with-input-context ('expression :override nil) (object type) (read-gesture :stream stream) - (expression (performing-drei-operations (drei :with-undo t) + (expression (performing-drei-operations (drei :with-undo t + :redisplay t) (presentation-replace-input stream object type (view drei) :buffer-start (stream-insertion-pointer stream) :allow-other-keys t - :accept-result nil)) + :accept-result nil + :rescan t)) + (rescan-if-necessary stream) nil)) ;; True if `gesture' was freshly read from the user, and not ;; just retrieved from the buffer during a rescan. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/14 07:48:30 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/17 20:18:56 1.6 @@ -535,7 +535,10 @@ :documentation "The kill ring object associated with the Drei instance.") (%previous-command :initform nil - :accessor previous-command) + :accessor previous-command + :documentation "The previous CLIM command +executed by this Drei instance. May be NIL if no command has been +executed.") (%point-cursor :accessor point-cursor :initarg :point-cursor :type cursor @@ -565,7 +568,7 @@ :initarg :minibuffer :type (or minibuffer-pane null) :documentation "The minibuffer pane (or null) -associated with the Drei instance.") +associated with the Drei instance. This may be NIL.") (%command-table :initform (make-instance 'drei-command-table :name 'drei-dispatching-table) :reader command-table @@ -575,8 +578,10 @@ looking up commands for the Drei instance. Has a sensible default, don't override it unless you know what you are doing.")) (:default-initargs :active t :editable-p t) - (:documentation "An abstract Drei class that should not be -directly instantiated.")) + (:documentation "The abstract Drei class that maintains +standard Drei editor state. It should not be directly +instantiated, a subclass implementing specific behavior (a Drei +variant) should be used instead.")) (defmethod (setf active) :after (new-val (drei drei)) (mapcar #'(lambda (cursor) @@ -616,7 +621,7 @@ bot (clone-mark (high-mark buffer) :right)))) ;; Main redisplay entry point. -(defgeneric display-drei (frame drei) +(defgeneric display-drei (drei) (:documentation "Display the given Drei instance.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -626,7 +631,9 @@ (defmacro handling-drei-conditions (&body body) "Evaluate `body' while handling Drei user notification signals. The handling consists of displaying their meaning to the -user in the minibuffer." +user in the minibuffer. This is the macro that ensures conditions +such as `motion-before-end' does not land the user in the +debugger." `(handler-case (progn ,@body) (offset-before-beginning () (beep) (display-message "Beginning of buffer")) @@ -673,7 +680,9 @@ from `drei-instance'. The keyword arguments can be used to provide forms that will be used to obtain values for the respective special variables, instead of finding their value in -`drei-instance'." +`drei-instance'. This macro binds all of the usual Drei special +variables, but also some CLIM special variables needed for +ESA-style command parsing." (once-only (drei-instance) `(let* ((*current-buffer* ,(or current-buffer `(buffer ,drei-instance))) (*current-window* ,(or current-window drei-instance)) @@ -697,15 +706,17 @@ &key with-undo (update-syntax t) (redisplay t)) (with-accessors ((buffer buffer)) drei (with-undo ((when with-undo (list buffer))) - (funcall continuation) - (when update-syntax - (update-syntax buffer (syntax buffer)) - (when (modified-p buffer) - (clear-modify buffer))) - (when redisplay - (display-drei *application-frame* drei)) - (unless with-undo - (clear-undo-history (buffer drei)))))) + (funcall continuation)) + (when (or update-syntax redisplay) + (update-syntax buffer (syntax buffer))) + (unless with-undo + (clear-undo-history (buffer drei))) + (when redisplay + (etypecase drei + (pane + (redisplay-frame-pane *application-frame* drei)) + (t + (display-drei drei)))))) (defmacro performing-drei-operations ((drei &rest args &key with-undo (update-syntax t) @@ -718,7 +729,8 @@ redisplayed, the syntax updated, etc. Exactly what is done can be controlled via the keyword arguments. Note that if `with-undo' is false, the *entire* undo history will be cleared after `body' has -been evaluated." +been evaluated. This macro expands into a call to +`invoke-performing-drei-operations'." (declare (ignore with-undo update-syntax redisplay)) `(invoke-performing-drei-operations ,drei (lambda () ,@body) @@ -772,7 +784,8 @@ can be done to arbitrary streams from within `body'. Or, at least, make sure the Drei instance will not be a problem. When Drei calls a command, it will be wrapped in this macro, so it -should be safe to use `accept' within Drei commands." +should be safe to use `accept' within Drei commands. This macro +expands into a call to `invoke-accepting-from-user'." `(invoke-accepting-from-user ,drei #'(lambda () ,@body))) ;;; Plain `execute-frame-command' is not good enough for us. Our @@ -780,29 +793,19 @@ ;;; that it is also responsible for updating the syntax of the buffer ;;; in the pane. (defgeneric execute-drei-command (drei-instance command) - (:documentation "Execute a CLIM command for a given Drei -instance. Methods defined on this generic function should set up -things like handling some Drei conditions, setting up undo, -etc.")) - -(defun execute-drei-command-for-frame (frame drei-instance command) - "Execute `command' using `execute-frame-command' on -`frame'. This function will handle Drei conditions and display -them on the minibuffer, as well as recording whatever changes -`command' makes to the buffer in the undo tree, and update the -syntax to reflect the changes." - (with-accessors ((buffer buffer)) drei-instance - (handling-drei-conditions - ;; Must be a list of buffers, so wrap in call to `list'. - (with-undo ((list buffer)) - (accepting-from-user (drei-instance) - (execute-frame-command frame command))) - (setf (previous-command drei-instance) command) - (update-syntax buffer (syntax buffer)) - (when (modified-p buffer) - (clear-modify buffer))))) + (:documentation "Execute `command' for `drei'. This is the +standard function for executing Drei commands - it will take care +of reporting to the user if a condition is signalled, updating +the syntax, setting the `previous-command' of `drei' and +recording the operations performed by `command' for undo.")) (defmethod execute-drei-command ((drei drei) command) - (let ((*standard-input* (or *minibuffer* *standard-input*))) - (execute-drei-command-for-frame (pane-frame (editor-pane drei)) - drei command))) + (with-accessors ((buffer buffer)) drei + (let ((*standard-input* (or *minibuffer* *standard-input*))) + (performing-drei-operations (drei :redisplay nil + :update-syntax t + :with-undo t) + (handling-drei-conditions + (accepting-from-user (drei) + (apply (command-name command) (command-arguments command))) + (setf (previous-command drei) command)))))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/09 00:52:01 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/17 20:18:56 1.4 @@ -394,27 +394,14 @@ (round (- cursor-x))) 0))))))) -(defun display-drei-gadget (drei &key force-p (display-minibuffer t)) - "Redisplay the given Drei pane. If `display-minibuffer' is -non-NIL (the default), also redisplay the minibuffer associated -with the Drei instance. Use this from the event handlers so -`*standard-output*' is properly bound." - (let ((*standard-output* drei)) - (redisplay-frame-pane (pane-frame drei) drei :force-p force-p)) - (when display-minibuffer - (with-accessors ((minibuffer minibuffer)) drei - (let* ((minibuffer (or minibuffer *minibuffer*)) - (*standard-output* minibuffer)) - (redisplay-frame-pane (pane-frame minibuffer) minibuffer))))) - (defmethod handle-repaint :before ((pane drei-pane) region) (declare (ignore region)) (redisplay-frame-pane (pane-frame pane) pane)) -(defun display-drei-pane (drei-pane current-p) +(defun display-drei-pane (frame drei-pane) "Display `pane'. If `pane' has focus, `current-p' should be non-NIL." - (declare (ignore current-p)) + (declare (ignore frame)) (with-accessors ((buffer buffer) (top top) (bot bot) (point-cursor point-cursor)) drei-pane (if (full-redisplay-p drei-pane) --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/14 07:48:30 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/17 20:18:56 1.7 @@ -150,7 +150,7 @@ :end-of-line-action :scroll :background *background-color* :foreground *foreground-color* - :display-function 'display-drei + :display-function 'display-drei-pane :default-view +drei-textual-view+ :width 900 :active nil) @@ -158,6 +158,9 @@ permits (and requires) the host application to control the command loop completely.")) +(defmethod display-drei ((drei drei-pane)) + (redisplay-frame-pane (pane-frame drei) drei)) + (defmethod editor-pane ((drei drei-pane)) ;; The whole point of the `drei-pane' class is that it's its own ;; display surface. @@ -241,12 +244,12 @@ (defmethod armed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) (setf (active gadget) t) - (display-drei-gadget gadget :display-minibuffer nil)) + (display-drei gadget)) (defmethod disarmed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) (setf (active gadget) nil) - (display-drei-gadget gadget :display-minibuffer nil)) + (display-drei gadget)) (defun handle-new-gesture (drei gesture) (let ((*command-processor* drei) @@ -259,8 +262,24 @@ (unbound-gesture-sequence (c) (display-message "~A is unbound" (gesture-name (gestures c)))) (abort-gesture () - (display-message "Aborted"))) - (redisplay-frame-pane (pane-frame drei) drei)))) + (display-message "Aborted")))))) + +(defmethod execute-drei-command :around ((drei drei-gadget-pane) command) + (with-accessors ((buffer buffer)) drei + (let* ((*minibuffer* (or *minibuffer* + (unless (eq drei *standard-input*) + *standard-input*)))) + (call-next-method)) + (redisplay-frame-pane (pane-frame drei) drei) + (when (modified-p buffer) + (clear-modify buffer)))) + +(defmethod execute-drei-command :after ((drei drei-gadget-pane) command) + (with-accessors ((buffer buffer)) drei + (when (syntax buffer) + (update-syntax buffer (syntax buffer))) + (when (modified-p buffer) + (setf (needs-saving buffer) t)))) ;;; This is the method that functions as the entry point for all Drei ;;; gadget logic. @@ -280,14 +299,7 @@ (unwind-protect (progn (deactivate-gadget drei) (funcall continuation)) (activate-gadget drei) - ;; XXX: Work around McCLIM brokenness: - #+(or mcclim building-mcclim) (climi::arm-gadget drei t))) - -(defmethod execute-drei-command ((drei drei-gadget-pane) command) - (let* ((*minibuffer* (or *minibuffer* - (unless (eq drei *standard-input*) - *standard-input*)))) - (execute-drei-command-for-frame (pane-frame drei) drei command))) + (setf (active drei) t))) (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) @@ -314,6 +326,9 @@ &key) (tree-recompute-extent area)) +(defmethod display-drei ((drei drei-area)) + (display-drei-area drei)) + ;; For areas, we need to switch to ESA abort gestures after we have ;; left the CLIM gesture reading machinery, but before we start doing ;; ESA gesture processing. @@ -343,18 +358,11 @@ (:documentation "A constellation of a Drei gadget instance and a minibuffer.")) -(defmethod display-drei (frame (drei drei-pane)) - (declare (ignore frame)) - (display-drei-pane drei (active drei))) - -(defmethod display-drei :after (frame (drei drei)) +(defmethod display-drei :after ((drei drei)) (with-accessors ((minibuffer minibuffer)) drei (when (and minibuffer (not (eq minibuffer (editor-pane drei)))) (redisplay-frame-pane (pane-frame minibuffer) minibuffer)))) -(defmethod display-drei (frame (drei drei-area)) - (display-drei-area drei)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Programmer interface stuff

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by crhodes 17 Nov '06

17 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv4741 Modified Files: dev-commands.lisp listener.lisp Log Message: A bit more prettiness: define a stream-present method to enforce :single-box t on listener-interactor streams; pass :single-box t explicitly to with-output-as-presentation, which is different. Make package prompts be presented as type 'package. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 09:51:18 1.36 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 12:30:56 1.37 @@ -106,7 +106,8 @@ (write-char #\( stream) (present arg 'symbol :stream stream) (write-char #\space stream) - (with-output-as-presentation (stream spec 'specializer) + (with-output-as-presentation (stream spec 'specializer + :single-box t) (if (typep spec 'class) (format stream "~S" (clim-mop:class-name spec)) (format stream "~S" `(eql ,(clim-mop:eql-specializer-object spec))))) @@ -476,7 +477,8 @@ :text-style text-style) ;; Present class name rather than class here because the printing of the ;; class object itself is rather long and freaks out the pointer doc pane. - (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) + (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name + :single-box t) ; (surrounding-output-with-border (stream :shape :drop-shadow) (princ (clim-mop:class-name class) stream)))) ;) inferior-fun @@ -567,7 +569,7 @@ (with-ink (,var) ,@body) ))) (fcell (name :left) - (with-output-as-presentation (t slot 'slot-definition) + (with-output-as-presentation (t slot 'slot-definition :single-box t) (princ name)) (unless (eq type t) (fresh-line) @@ -602,13 +604,13 @@ (with-ink (readers) (if readers (dolist (reader readers) - (present reader (presentation-type-of reader) :single-box t) + (present reader (presentation-type-of reader)) (terpri)) (note "No readers~%"))) (with-ink (writers) (if writers (dolist (writer writers) - (present writer (presentation-type-of writer) :single-box t) + (present writer (presentation-type-of writer)) (terpri)) (note "No writers")))))) @@ -687,7 +689,7 @@ (invoke-as-heading (lambda () (format t "~&Slots for ") - (with-output-as-presentation (t (clim-mop:class-name class) 'class-name) + (with-output-as-presentation (t (clim-mop:class-name class) 'class-name :single-box t) (princ (clim-mop:class-name class))))) (present-the-slots class) )))))) @@ -916,7 +918,8 @@ do (progn (with-output-as-presentation (*standard-output* (clim-mop:class-name class) - 'class-name) + 'class-name + :single-box t) (format *standard-output* "~S~%" (clim-mop:class-name class))))))) (when methods @@ -1009,7 +1012,8 @@ normal-ink (make-rgb-color 0.4 0.4 0.4)) :text-style text-style) - (with-output-as-presentation (stream package 'package) + (with-output-as-presentation (stream package 'package + :single-box t) (format stream "~A (~D/~D)" (package-name package) internal external))))) inferior-fun :stream stream @@ -1061,7 +1065,8 @@ :version (pathname-version pathname)))))) (defun pretty-pretty-pathname (pathname stream &key (long-name t)) - (with-output-as-presentation (stream pathname 'clim:pathname) + (with-output-as-presentation (stream pathname 'clim:pathname + :single-box t) (let ((icon (icon-of pathname))) (when icon (draw-icon stream icon :extra-spacing 3))) (princ (pathname-printing-name pathname long-name) stream)) @@ -1135,7 +1140,7 @@ (format t " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname) + (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname :single-box t) (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) (format t "Parent Directory~%"))) @@ -1441,19 +1446,23 @@ (with-drawing-options (t :ink +olivedrab+) (cond ((null values) (format t "No values.~%")) - ((= 1 (length values)) - (present (first values) (presentation-type-of (first values)) - :single-box t) + ((= 1 (length values)) + (let ((o (first values))) + (with-output-as-presentation (t o (presentation-type-of o) + :single-box t) + (present (first values) 'expression))) (fresh-line)) - (t (do ((i 0 (1+ i)) - (item values (rest item))) - ((null item)) + (t (do* ((i 0 (1+ i)) + (items values (rest items)) + (o (first items) (first items))) + ((null items)) (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (present (first item) (presentation-type-of (first item)) - :single-box t) - (fresh-line)))))) + (with-output-as-presentation (t o (presentation-type-of o) + :single-box t) + (present o 'expression)) + (fresh-line)))))) (defun shuffle-specials (form values) (setf +++ ++ @@ -1510,7 +1519,7 @@ (invoke-as-heading (lambda () (format t "Command table ") - (with-output-as-presentation (t ct 'clim:command-table) + (with-output-as-presentation (t ct 'clim:command-table :single-box t) (princ (command-table-name ct))))) (if commands (format-items commands :printer (lambda (cmd s) (present cmd 'clim:command-name :stream s)) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 09:51:18 1.27 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 12:30:56 1.28 @@ -186,15 +186,35 @@ (values result type) (input-not-of-required-type result type)))) +;;; Listener interactor stream. If only STREAM-PRESENT were +;;; specializable on the VIEW argument, this wouldn't be necessary. +;;; However, it isn't, so we have to play this game. We currently +;;; only use this to get single-box presentation highlighting. + +(defclass listener-interactor-pane (interactor-pane) ()) + +(defmethod stream-present :around + ((stream listener-interactor-pane) object type + &rest args &key (single-box nil sbp) &allow-other-keys) + (apply #'call-next-method stream object type :single-box t args) + ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all + ;; the keyword arguments explicitly. *sigh*. + #+nil + (if sbp + (call-next-method) + (apply #'call-next-method stream object type :single-box t args))) + ;;; Listener application frame (define-application-frame listener (standard-application-frame command-history-mixin) ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) - (:panes (interactor :interactor :scroll-bars t - :display-function #'listener-initial-display-function - :display-time t) + (:panes (interactor-container + (make-clim-stream-pane + :type 'listener-interactor-pane + :name 'interactor :scroll-bars t :display-time t + :display-function #'listener-initial-display-function)) (doc :pointer-documentation) (wholine (make-pane 'wholine-pane :display-function 'display-wholine :scroll-bars nil @@ -210,7 +230,7 @@ (:menu-bar t) (:layouts (default (vertically () - interactor + interactor-container doc wholine)))) @@ -298,16 +318,17 @@ object type) (flet ((sensitizer (stream cont) (case type - ((command) (with-output-as-presentation - (stream object type :single-box t) + ((command) (with-output-as-presentation (stream object type :single-box t) (funcall cont))) - ((form) (with-output-as-presentation - (stream object 'command :single-box t) - (with-output-as-presentation - (stream (cadr object) - (presentation-type-of (cadr object)) - :single-box t) - (funcall cont)))) + ((form) + (with-output-as-presentation (stream object 'command :single-box t) + (with-output-as-presentation + (stream (cadr object) 'expression :single-box t) + (with-output-as-presentation + (stream (cadr object) + (presentation-type-of (cadr object)) + :single-box t) + (funcall cont))))) (t (funcall cont))))) (handler-case ;; Body @@ -354,15 +375,15 @@ (command ;; Kludge the cursor position - Goatee will have moved it all around (setf (stream-cursor-position stream) (values x y)) - (present object object-type - :view (stream-default-view stream) - :stream stream :single-box t) + (present object object-type :stream stream + :view (stream-default-view stream)) object)))) (defun print-listener-prompt (stream frame) (declare (ignore frame)) (with-text-face (stream :italic) - (print-package-name stream) + (with-output-as-presentation (stream *package* 'package :single-box t) + (print-package-name stream)) (princ "> " stream))) (defmethod frame-standard-output ((frame listener))

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by crhodes 17 Nov '06

17 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv6416 Modified Files: dev-commands.lisp listener.lisp Log Message: Replace HACKISH-PRESENT with a view class mixin. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/04/10 21:24:53 1.35 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 09:51:18 1.36 @@ -602,13 +602,13 @@ (with-ink (readers) (if readers (dolist (reader readers) - (hackish-present reader) + (present reader (presentation-type-of reader) :single-box t) (terpri)) (note "No readers~%"))) (with-ink (writers) (if writers (dolist (writer writers) - (hackish-present writer) + (present writer (presentation-type-of writer) :single-box t) (terpri)) (note "No writers")))))) @@ -1437,18 +1437,13 @@ ;;; Eval -(defun hackish-present (object) - "Hack of the day.. let McCLIM determine presentation type to use, except for lists, because the list presentation method is inappropriate for lisp return values." - (typecase object - (sequence (present object 'expression)) - (t (present object)))) - (defun display-evalues (values) (with-drawing-options (t :ink +olivedrab+) (cond ((null values) (format t "No values.~%")) ((= 1 (length values)) - (hackish-present (first values)) + (present (first values) (presentation-type-of (first values)) + :single-box t) (fresh-line)) (t (do ((i 0 (1+ i)) (item values (rest item))) @@ -1456,7 +1451,8 @@ (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (hackish-present (first item)) + (present (first item) (presentation-type-of (first item)) + :single-box t) (fresh-line)))))) (defun shuffle-specials (form values) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/05/10 11:19:33 1.26 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 09:51:18 1.27 @@ -150,7 +150,41 @@ (lambda () (funcall *listener-initial-function*) (fresh-line))))) - + +;;; Listener view +;;; +;;; FIXME: this TEXTUAL-VIEW thing is a lie: we can draw graphics. +;;; However, all the various presentation methods around the world are +;;; specialized on textual view, and it sucks to have to reimplement +;;; them all. +(defclass listener-view (textual-view) ()) + +(defclass listener-pointer-documentation-view + (listener-view pointer-documentation-view) + ()) + +(defparameter +listener-view+ (make-instance 'listener-view)) +(defparameter +listener-pointer-documentation-view+ + (make-instance 'listener-pointer-documentation-view)) + +(define-presentation-method present :around + ((object sequence) (type sequence) stream (view listener-view) + &key acceptably for-context-type) + (present object 'expression :stream stream :view view + :acceptably acceptably :for-context-type for-context-type)) + +(define-presentation-method accept :around + ((type sequence) stream (view listener-view) &key default default-type) + (let* ((token (read-token stream)) + (result (handler-case (read-from-string token) + (error (c) + (declare (ignore c)) + (simple-parse-error + "Error parsing ~S for presentation type ~S" + token type))))) + (if (presentation-typep result type) + (values result type) + (input-not-of-required-type result type)))) ;;; Listener application frame (define-application-frame listener (standard-application-frame @@ -213,7 +247,11 @@ (*read-default-float-format* *read-default-float-format*) (*read-eval* *read-eval*) (*read-suppress* *read-suppress*) - (*readtable* *readtable*)) + (*readtable* *readtable*)) + (setf (stream-default-view (get-frame-pane frame 'interactor)) + +listener-view+) + (setf (stream-default-view (get-frame-pane frame 'doc)) + +listener-pointer-documentation-view+) (loop while (catch 'return-to-listener (restart-case (call-next-method) @@ -258,43 +296,52 @@ (let* ((command-table (find-command-table 'listener)) (*accelerator-gestures* (climi::compute-inherited-keystrokes command-table)) object type) - (handler-case - ;; Body - (with-input-editing (stream :input-sensitizer - (lambda (stream cont) - (if type - (with-output-as-presentation - (stream object type) - (funcall cont)) - (funcall cont)))) - (let ((c (read-gesture :stream stream :peek-p t))) - (setf object - (if (member c *form-opening-characters*) - (prog2 - (when (char= c #\,) - (read-gesture :stream stream)) ; lispm behavior - #| ---> |# (list 'com-eval (accept 'form :stream stream :prompt nil)) - (setf type 'command #|'form|# )) ; FIXME? - (prog1 - (accept '(command :command-table listener) :stream stream - :prompt nil) - (setf type 'command)))))) - ;; Handlers - ((or simple-parse-error input-not-of-required-type) (c) - (beep) - (fresh-line *query-io*) - (princ c *query-io*) - (terpri *query-io*) - nil) - (accelerator-gesture (c) - (let ((command (lookup-keystroke-command-item (accelerator-gesture-event c) - command-table))) - (setf ;type 'command - object (if (partial-command-p command) - (funcall *partial-command-parser* - command-table stream command - (position *unsupplied-argument-marker* command)) - command))))) + (flet ((sensitizer (stream cont) + (case type + ((command) (with-output-as-presentation + (stream object type :single-box t) + (funcall cont))) + ((form) (with-output-as-presentation + (stream object 'command :single-box t) + (with-output-as-presentation + (stream (cadr object) + (presentation-type-of (cadr object)) + :single-box t) + (funcall cont)))) + (t (funcall cont))))) + (handler-case + ;; Body + (with-input-editing + (stream :input-sensitizer #'sensitizer) + (let ((c (read-gesture :stream stream :peek-p t))) + (setf object + (if (member c *form-opening-characters*) + (prog2 + (when (char= c #\,) + ;; lispm behavior + (read-gesture :stream stream)) + (list 'com-eval (accept 'form :stream stream :prompt nil)) + (setf type 'form)) + (prog1 + (accept '(command :command-table listener) :stream stream + :prompt nil) + (setf type 'command)))))) + ;; Handlers + ((or simple-parse-error input-not-of-required-type) (c) + (beep) + (fresh-line *query-io*) + (princ c *query-io*) + (terpri *query-io*) + nil) + (accelerator-gesture (c) + (let ((command (lookup-keystroke-command-item (accelerator-gesture-event c) + command-table))) + (setf ;type 'command + object (if (partial-command-p command) + (funcall *partial-command-parser* + command-table stream command + (position *unsupplied-argument-marker* command)) + command)))))) object))) (defmethod read-frame-command :around ((frame listener) @@ -303,14 +350,14 @@ and whatever else need be done." (multiple-value-bind (x y) (stream-cursor-position stream) (with-input-context ('command) (object object-type) - (call-next-method) - (command - ;; Kludge the cursor position - Goatee will have moved it all around - (setf (stream-cursor-position stream) (values x y)) - (present object object-type - :view (stream-default-view stream) - :stream stream) - object)))) + (call-next-method) + (command + ;; Kludge the cursor position - Goatee will have moved it all around + (setf (stream-cursor-position stream) (values x y)) + (present object object-type + :view (stream-default-view stream) + :stream stream :single-box t) + object)))) (defun print-listener-prompt (stream frame) (declare (ignore frame)) @@ -328,14 +375,14 @@ (process-name "Listener") (eval nil)) (flet ((run () - (run-frame-top-level - (make-application-frame 'listener - :width width - :height height - :system-command-reader system-command-reader) - :listener-funcall (cond ((null eval) nil) - ((functionp eval) eval) - (t (lambda () (eval eval))))))) + (let ((frame (make-application-frame + 'listener + :width width :height height + :system-command-reader system-command-reader))) + (run-frame-top-level + frame :listener-funcall (cond ((null eval) nil) + ((functionp eval) eval) + (t (lambda () (eval eval)))))))) (if new-process (clim-sys:make-process #'run :name process-name) (run))))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 16 Nov '06

16 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3986 Modified Files: buffer.lisp Log Message: Updated docstrings. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/16 19:22:38 1.2 @@ -31,7 +31,7 @@ (in-package :drei-buffer) (defclass buffer () () - (:documentation "A base class for all buffers. A buffer conceptually contains a + (:documentation "The base class for all buffers. A buffer conceptually contains a large array of arbitrary objects. Lines of objects are separated by newline characters. The last object of the buffer is not necessarily a newline character.")) @@ -47,31 +47,33 @@ (low-mark :reader low-mark) (high-mark :reader high-mark) (modified :initform nil :reader modified-p)) - (:documentation "The Drei standard buffer [an instantable subclass of buffer].")) + (:documentation "The standard instantiable class for buffers.")) (defgeneric buffer (mark) (:documentation "Return the buffer that the mark is positioned in.")) (defclass mark () () - (:documentation "A base class for all marks.")) + (:documentation "The base class for all marks.")) (defclass left-sticky-mark (mark) () - (:documentation "A subclass of mark. A mark of this type will \"stick\" to the left of -an object, i.e. when an object is inserted at this mark, the mark will -be positioned to the left of the object")) + (:documentation "A subclass of mark. A mark of this type will +\"stick\" to the left of an object, i.e. when an object is +inserted at this mark, the mark will be positioned to the left of +the object.")) (defclass right-sticky-mark (mark) () - (:documentation "A subclass of mark. A mark of this type will \"stick\" to the right of -an object, i.e. when an object is inserted at this mark, the mark will -be positioned to the right of the object.")) + (:documentation "A subclass of mark. A mark of this type will +\"stick\" to the right of an object, i.e. when an object is +inserted at this mark, the mark will be positioned to the right +of the object.")) (defgeneric offset (mark) (:documentation "Return the offset of the mark into the buffer.")) (defgeneric (setf offset) (new-offset mark) - (:documentation "Set the offset of the mark into the buffer. A no-such-offset -condition is signaled if the offset is less than zero or greater than -the size of the buffer.")) + (:documentation "Set the offset of the mark into the buffer. A +no-such-offset condition is signaled if the offset is less than +zero or greater than the size of the buffer.")) (defclass mark-mixin () ((buffer :initarg :buffer :reader buffer) @@ -85,9 +87,9 @@ ((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.")) + (: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) () @@ -186,10 +188,10 @@ (setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer)))) (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.")) + (: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 standard-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 14 Nov '06

14 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3441/Drei Modified Files: basic-commands.lisp Log Message: Reactivate the arrow keys. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 10:31:37 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 19:43:36 1.3 @@ -146,7 +146,7 @@ (set-key `(com-forward-object ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :right #-mcclim :right-arrow))) + '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow))) (set-key `(com-backward-object ,*numeric-argument-marker*) 'movement-table @@ -154,7 +154,7 @@ (set-key `(com-backward-object ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :left #-mcclim :left-arrow))) + '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow))) (set-key `(com-forward-word ,*numeric-argument-marker*) 'movement-table @@ -162,7 +162,7 @@ (set-key `(com-forward-word ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :right #-mcclim :right-arrow :control))) + '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow :control))) (set-key `(com-backward-word ,*numeric-argument-marker*) 'movement-table @@ -170,7 +170,7 @@ (set-key `(com-backward-word ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :left #-mcclim :left-arrow :control))) + '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow :control))) (set-key `(com-forward-line ,*numeric-argument-marker*) 'movement-table @@ -178,7 +178,7 @@ (set-key `(com-forward-line ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :down #-mcclim :down-arrow))) + '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow))) (set-key `(com-backward-line ,*numeric-argument-marker*) 'movement-table @@ -186,7 +186,7 @@ (set-key `(com-backward-line ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :up #-mcclim :up-arrow))) + '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow))) (set-key 'com-beginning-of-line 'movement-table @@ -218,7 +218,7 @@ (set-key `(com-backward-paragraph ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :up #-mcclim :up-arrow :control))) + '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow :control))) (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table @@ -226,7 +226,7 @@ (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :down #-mcclim :down-arrow :control))) + '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[mcclim-cvs] CVS mcclim/Doc
by thenriksen 14 Nov '06

14 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv27277 Modified Files: Makefile mcclim.texi Added Files: drei.texi Log Message: Added preliminary Drei documentation. --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/11/11 15:33:21 1.4 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/11/14 18:44:27 1.5 @@ -9,7 +9,7 @@ inspect-object-2.eps inspect-object-3.eps native.fig IMAGETARGETTYPES=gif png eps TARGETIMAGES=$(shell sh ./makeimages.sh -e "$(IMAGES)" "$(IMAGETARGETTYPES)") -TEXIFILES=$(NAME).texi +TEXIFILES=$(NAME).texi drei.texi all : $(NAME).ps $(NAME2).ps @@ -31,7 +31,7 @@ sh ./makeimages.sh "$(IMAGES)" "$(IMAGETARGETTYPES)" $(NAME).html: $(TEXIFILES) - makeinfo --html $< + makeinfo --html $(NAME).texi $(NAME).ps: $(NAME).dvi dvips $< -o --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/11 15:33:21 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/14 18:44:27 1.2 @@ -43,11 +43,6 @@ @cindex \ENTRY\ @end macro -@macro func{NAME} -@t{\NAME\} -@findex \NAME\ -@end macro - @macro fmacro{MACRO} @func{\MACRO\} @end macro @@ -57,15 +52,15 @@ @end macro @alias gloss = i -@alias class = t -@alias gadget = t -@alias pane = t -@alias initarg = t +@alias class = code +@alias package = code +@alias gadget = code +@alias pane = code @alias methcomp = t -@alias slot = t +@alias slot = code @alias longref = t -@alias cl = t -@alias initarg = t +@alias cl = code +@alias initarg = code @ifnottex @node Top @@ -77,45 +72,47 @@ * Introduction:: Getting started -* CLIM Demos and Applications:: -* The First Application:: +* CLIM Demos and Applications:: +* The First Application:: * Using presentation types:: -User Manual -* Using views:: +User Manual +* Using views:: * Using command tables:: Reference Manual -* Concepts:: -* Windowing system drawing functions:: -* CLIM drawing functions:: -* Panes:: -* Output Protocol:: +* Concepts:: +* Windowing system drawing functions:: +* CLIM drawing functions:: +* Panes:: +* Output Protocol:: * Command Processing:: Extensions -* Output Protocol Extensions:: -* Output Recording Extensions:: +* Output Protocol Extensions:: +* Output Recording Extensions:: * Drawing Two-Dimensional Images:: * File Selector Gadget:: * PostScript Backend:: +* Drei:: -Utility Programs -* Listener:: +Utility Programs +* Listener:: * Inspector:: -Auxilliary Material +Auxilliary Material * Glossary:: * Development History:: Index * Concept Index:: +* Variable Index:: * Function Index:: @end menu @node Introduction @chapter Introduction -@cindex Ehtoota +@cindex ehtoota CLIM is a large layered software system that allows the user to customize it at each level. The most simple ways of using CLIM is to @@ -154,7 +151,7 @@ often clearer than the official specification; on the other hand, the original specification is a useful reference. This manual will note where McCLIM has followed the 2.2 API. -@cindex Specification +@cindex specification Also, some protocols mentioned in the 2.0 specification, such as parts of the incremental redisplay protocol, are clearly internal to CLIM and @@ -175,10 +172,10 @@ with objects of the application. In fact, CLIM doesn't have to be used with graphics output at all, as it contains a large collection of functionality to manage text. -@cindex Interface manager +@cindex interface manager Traditional GUI toolkits have an @emph{event loop}. -@cindex Event loop +@cindex event loop Events are delivered to GUI elements called @emph{gadgets} (or @emph{widgets}), and the programmer attaches @emph{event handlers} to those gadgets in order to invoke the functionality of the application @@ -191,8 +188,8 @@ At the lowest level, CLIM also has an event loop, but most application programmers never have any reason to program at that level with CLIM. -Instead, CLIM has a @emph{command loop} -@cindex Command loop +Instead, CLIM has a @emph{command loop} +@cindex command loop at a much higher level than the event loop. At each iteration of the command loop: @@ -248,7 +245,7 @@ @node CLIM Demos and Applications @chapter CLIM Demos and Applications -@cindex Demo applications +@cindex demo applications @menu * Running the Demos:: @@ -376,7 +373,7 @@ @node Multiprocessing with CMUCL @subsection Multiprocessing with CMUCL -@cindex Multiprocessing +@cindex multiprocessing Before beginning a McCLIM session with CMUCL, @b{you are strongly advised} to initialize multiprocessing by evaluating the form: @@ -411,8 +408,8 @@ @node The First Application @chapter The First Application -@cindex Building an application -@cindex Writing an application +@cindex building an application +@cindex writing an application @menu * Panes and Gadgets:: @@ -433,8 +430,8 @@ CLIM gadgets are @gadget{button}s, @gadget{slider}s, etc, and typical panes are the layout panes such as @pane{hbox}, @pane{vbox}, @pane{hrack}, etc. -@cindex Pane -@cindex Gadget +@cindex pane +@cindex gadget @node Defining Application Frames @section Defining Application Frames @@ -447,7 +444,7 @@ your application-specific data in slots in the application frame (rather than, say, in global variables), and to define your application-specific application frame in its own package. -@cindex Application frame +@cindex application frame The usual way to define an application frame is to use the macro @fmacro{define-application-frame}. This macro works much like @@ -468,11 +465,12 @@ package, here a package named @t{APP}. While not required, putting the application in its own package is good practice. -The package for the application uses two packages: @t{CLIM} and -@t{CLIM-LISP}. The @t{CLIM} package is the one that contains all the -symbols needed for using CLIM. The @t{CLIM-LISP} package replaces the -@t{COMMON-LISP} package for CLIM applications. It is essentially the -same as the @t{COMMON-LISP} package as far as the user is concerned. +The package for the application uses two packages: @package{CLIM} and +@package{CLIM-LISP}. The @package{CLIM} package is the one that +contains all the symbols needed for using CLIM. The @package{CLIM-LISP} +package replaces the @package{COMMON-LISP} package for CLIM +applications. It is essentially the same as the @package{COMMON-LISP} +package as far as the user is concerned. In our example, we export the symbol that corresponds to the main function to start our application, here called @t{APP-MAIN}. @@ -493,8 +491,10 @@ frame. These slots are typically used for holding all application-specific data. The current instance of the application frame will always be the value of the special variable -@t{*application-frame*}, so that the values of these slots can be -accessed. In our example, we do not initially have any further slots. +@t{*application-frame*}, +@vindex *application-frame* +so that the values of these slots can be accessed. In our example, we +do not initially have any further slots. The rest of the definition of an application frame contains additional elements that CLIM will allow the user to define. In our example, we @@ -555,8 +555,8 @@ With the option @t{:display-time nil}, the pane is never cleared, and output is accumulated every time we execute the @t{parity} command. -For this example, let us also add a few @emph{commands}. -@cindex Command +For this example, let us also add a few @emph{commands}. +@cindex command Such commands are defined by the use of a macro called @fmacro{@t{define-}@i{name}@t{-command}}, where @i{name} is the name of the application, in our case @t{superapp}. This macro is automatically @@ -617,7 +617,7 @@ at all times, and that is modified by the commands of the application. CLIM allows for a very easy way to write such an application. The main idea is to store the data structure in slots of the application frame, -and to use a @emph{display function} +and to use a @emph{display function} @cindex display function that after each iteration of the command loop displays the entire data structure to the application pane. @@ -630,7 +630,7 @@ @end lisp Here, we have added a slot that is called @t{current-number} to the -application frame. It is initialized to @t{NIL} and it has an accessor +application frame. It is initialized to @cl{NIL} and it has an accessor function that allow us to query and to modify the value. Observe that in this example, we no longer have the option @@ -655,7 +655,7 @@ that will result in output. This makes it possible for the same function to be used by several different frames, should that be called for. In our simple example, the display function only displays the -value of a single number (or @t{NIL}), but you could think of this as +value of a single number (or @cl{NIL}), but you could think of this as displaying all the objects that have been drawn in some figure drawing program or displaying all the entries in an address book. @@ -730,7 +730,7 @@ @node Using presentation types @chapter Using presentation types -@cindex Presentation type +@cindex presentation type @menu * What is a presentation type:: @@ -811,7 +811,7 @@ @node Using views @chapter Using views -@cindex View +@cindex view The CLIM specification mentions a concept called a @emph{view}, and also lists a number of predefined views to be used in various different @@ -877,7 +877,7 @@ @node Using command tables @chapter Using command tables -@cindex Command table +@cindex command table (to be filled in) @@ -900,17 +900,17 @@ The coordinate system used for the arguments of drawing functions is called the @gloss{user coordinate system}, -@cindex User coordinate system +@cindex user coordinate system and coordinate values expressed in the user coordinate system are known as @gloss{user coordinates}. -@cindex User coordinates +@cindex user coordinates Each sheet has its own coordinate system called the @gloss{sheet coordinate system}, -@cindex Sheet coordinate system +@cindex sheet coordinate system and positions expressed in this coordinate system are said to be expressed in @gloss{sheet coordinates}. -@cindex Sheet coordinates +@cindex sheet coordinates User coordinates are translated to @gloss{sheet coordinates} by means of the @gloss{user transformation} also called the @gloss{medium transformation}. This transformation is stored in the @gloss{medium} @@ -1043,7 +1043,7 @@ @node Panes @chapter Panes -@cindex Pane +@cindex pane Panes are subclasses of sheets. Some panes are @gloss{layout panes} that determine the size and position of its children according to rules @@ -1107,7 +1107,7 @@ @node Layout protocol @section Layout protocol -@cindex Layout protocol +@cindex layout protocol There is a set of fundamental rules of CLIM dividing responsibility between a parent pane and a child pane, with respect to the size and @@ -1296,9 +1296,9 @@ @node Command Processing @chapter Command Processing -@cindex Command -@cindex Command processing -@cindex Command tables +@cindex command +@cindex command processing +@cindex command tables @deffn {Macro} {define-command-table} name &key inherit-from menu inherit-menu @findex define-command-table @@ -1320,7 +1320,7 @@ @node Output Protocol Extensions @chapter Output Protocol Extensions -@cindex Extensions +@cindex extensions @deffn {Generic Function} {medium-miter-limit} medium @end deffn @@ -1332,7 +1332,7 @@ @node Output Recording Extensions @chapter Output Recording Extensions -@cindex Extensions +@cindex extensions @menu * Standard classes:: @@ -1577,6 +1577,8 @@ Loads a description of a font from the specified AFM file. +@include drei.texi + @c @node Utility Programs @c @part Utility Programs @@ -1588,7 +1590,7 @@ @node Inspector @chapter Inspector -@cindex Inspector +@cindex inspector @cindex Clouseau The inspector, called ``Clouseau'', is used for interactively inspecting @@ -1773,7 +1775,7 @@ many of them there are. It's written @math{\overline {x}} @lisp -(defgeneric mean (sample) +(defgeneric mean (sample) (:documentation "The mean of the numbers in a statistical sample")) @@ -2297,16 +2299,21 @@ cosmetic fixes to McCLIM and also worked on a GTK-like gadget set. He finally started work to get the OpenGL backend operational. -@node Concept Index -@unnumbered Concept Index +@node {Concept Index} +@unnumbered {Concept Index} @printindex cp -@node Function Index -@unnumbered Function Index +@node {Variable Index} +@unnumbered {Variable Index} + +@printindex vr + +@node {Function And Macro Index} +@unnumbered {Function And Macro Index} @printindex fn -@bye [4 lines skipped] --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/11/14 18:44:27 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/11/14 18:44:27 1.1 [2726 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 14 Nov '06

14 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29521/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax-commands.lisp Log Message: The Compile Definition command is not going to work properly in standalone Drei. Move to Climacs. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/14 12:27:53 1.2 @@ -1080,24 +1080,3 @@ (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" values))) (esa:display-message result))))) - -(defun compile-definition-interactively (mark syntax) - (let* ((token (definition-at-mark mark syntax)) - (string (token-string syntax token)) - (m (clone-mark mark)) - (buffer-name (name (buffer syntax))) - (*read-base* (base syntax))) - (with-syntax-package (syntax mark) - (forward-definition m syntax) - (backward-definition m syntax) - (multiple-value-bind (result notes) - (compile-form-for-drei (get-usable-image syntax) - (token-to-object syntax token - :read t - :package (package-at-mark syntax mark)) - (buffer syntax) - m) - (show-note-counts notes (second result)) - (when (not (null notes)) - (show-notes notes buffer-name - (one-line-ify (subseq string 0 (min (length string) 20))))))))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/14 12:27:53 1.2 @@ -184,12 +184,6 @@ (rotatef mark point)) (eval-region mark point *current-syntax*))) -(define-command (com-compile-definition :name t :command-table pane-lisp-table) - () - "Compile and load definition at point." - (evaluating-interactively - (compile-definition-interactively *current-point* *current-syntax*))) - (define-command (com-eval-last-expression :name t :command-table pane-lisp-table) ((insertp 'boolean :prompt "Insert?")) "Evaluate the expression before point in the local Lisp image." @@ -281,10 +275,6 @@ 'pane-lisp-table '((#\c :control) (#\r :control))) -(set-key 'com-compile-definition - 'pane-lisp-table - '((#\c :control) (#\c :control))) - (set-key `(com-eval-last-expression ,*numeric-argument-p*) 'pane-lisp-table '((#\c :control) (#\e :control)))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 14 Nov '06

14 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10285 Modified Files: basic-commands.lisp core-commands.lisp editing.lisp packages.lisp Log Message: Create object deletion/killing functions. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 10:31:37 1.2 @@ -371,13 +371,9 @@ "Delete the object after point. With a numeric argument, kill that many objects after (or before, if negative) point." - (let* ((point *current-point*) - (mark (clone-mark point))) - (forward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence point mark))) - (delete-region point mark))) + (if killp + (forward-kill-object *current-point* count) + (forward-delete-object *current-point* count))) (define-command (com-backward-delete-object :name t :command-table deletion-table) ((count 'integer :prompt "Number of Objects") @@ -385,13 +381,9 @@ "Delete the object before point. With a numeric argument, kills that many objects before (or after, if negative) point." - (let* ((point *current-point*) - (mark (clone-mark point))) - (backward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point))) + (if killp + (backward-kill-object *current-point* count) + (backward-delete-object *current-point* count))) ;; We require somewhat special behavior from Kill Line, so define a ;; new function and use that to implement the Kill Line command. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 08:02:27 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 10:31:37 1.3 @@ -428,7 +428,7 @@ 'string)))) (insert-sequence *current-point* line) (insert-object *current-point* #\Newline)) - (com-backward-delete-object 1 nil))) + (backward-delete-object *current-point*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/14 10:31:37 1.2 @@ -196,7 +196,64 @@ ;;; ;;; Object editing +(defun forward-delete-object (mark &optional (count 1) limit-action) + "Kill `count' objects beginning from `mark'." + (let ((offset (offset mark))) + (handler-case (progn (forward-object mark count) + (delete-region offset mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + count "object" nil)))))) + +(defun backward-delete-object (mark &optional (count 1) limit-action) + "Kill `count' objects backwards beginning from `mark'." + (let ((offset (offset mark))) + (handler-case (progn (backward-object mark count) + (delete-region offset mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + (- count) "object" nil)))))) + +(defun forward-kill-object (mark &optional (count 1) concatenate-p limit-action) + "Kill `count' objects beginning from `mark'." + (let ((start (offset mark))) + (handler-case (progn (forward-object mark count) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push + *kill-ring* (region-to-sequence start mark)) + (kill-ring-reverse-concatenating-push + *kill-ring* (region-to-sequence start mark))) + (kill-ring-standard-push + *kill-ring* (region-to-sequence start mark))) + (delete-region start mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + (- count) "object" nil)))))) + +(defun backward-kill-object (mark &optional (count 1) concatenate-p limit-action) + "Kill `count' objects backwards beginning from `mark'." + (let ((start (offset mark))) + (handler-case (progn (forward-object mark count) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push + *kill-ring* (region-to-sequence start mark)) + (kill-ring-reverse-concatenating-push + *kill-ring* (region-to-sequence start mark))) + (kill-ring-standard-push + *kill-ring* (region-to-sequence start mark))) + (delete-region start mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + (- count) "object" nil)))))) + (defun transpose-objects (mark) + "Transpose two objects at `mark'." (unless (beginning-of-buffer-p mark) (when (end-of-line-p mark) (backward-object mark)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/14 07:59:05 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/14 10:31:37 1.5 @@ -329,7 +329,11 @@ (defpackage :drei-editing (:use :clim-lisp :drei-base :drei-buffer :drei-syntax :drei-motion :drei :drei-kill-ring) - (:export #:transpose-objects + (:export #:forward-delete-object + #:backward-delete-object + #:forward-kill-object + #:backward-kill-object + #:transpose-objects ;; Lines #:forward-delete-line #:backward-delete-line

1 0