climacs-cvs July 2006

climacs-cvs@common-lisp.net

1 participants
48 discussions

[climacs-cvs] CVS climacs
by thenriksen 31 Jul '06

31 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17767 Modified Files: lisp-syntax.lisp Log Message: Use `menu-choose' for selecting symbols when doing symbol-completion. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/30 15:04:59 1.104 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/31 19:35:36 1.105 @@ -1,7 +1,9 @@ ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX -*- ;;; (c) copyright 2005 by -;;; Robert Strandh (7strandh(a)labri.fr) +;;; Robert Strandh (strandh(a)labri.fr) +;;; (c) copyright 2006 by +;;; Troels Henriksen (athas(a)sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -3154,7 +3156,8 @@ (defun arglist-keyword-p (arg) "Return T if `arg' is an arglist keyword. NIL otherwise." - (member arg +cl-arglist-keywords+)) + (when (member arg +cl-arglist-keywords+) + t)) (defun split-arglist-on-keywords (arglist) "Return an alist keying lambda list keywords of `arglist' @@ -3957,15 +3960,7 @@ (let* ((result (funcall fn symbol (package-name package))) (set (first result)) (longest (second result))) - (cond ((<=(length set) 1) - (clear-completions)) - (t (let ((stream (typeout-window "Completions"))) - (window-clear stream) - (format stream "~{~A~%~}" set)))) - (if (not (null longest)) - (esa:display-message (format nil "Longest is ~a|" longest)) - (esa:display-message "No completions found")) - longest)) + (values longest set))) (defun find-completion (syntax token package) (let ((symbol-name (token-string syntax token))) @@ -3989,16 +3984,7 @@ (esa:display-message (format nil "~a completions" symbol-name)) (let* ((set (fuzzy-completions (get-usable-image syntax) symbol-name package 10)) (best (caar set))) - (cond ((<= (length set) 1) - (clear-completions)) - (t (let ((stream (typeout-window "Completions"))) - (window-clear stream) - (loop for completed-string in set - do (format stream "~{~A ~}~%" completed-string))))) - (esa:display-message (if (not (null best)) - (format nil "Best is ~a|" best) - "No fuzzy completions found")) - best))) + (values best set)))) (defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completion)) "Attempt to find and complete the symbol at `mark' using the @@ -4011,9 +3997,26 @@ (not (= (start-offset token) (offset mark)))) (with-syntax-package syntax mark (package) - (let ((completion (funcall fn syntax token package))) - (unless (= (length completion) 0) - (replace-symbol-at-mark mark syntax completion)))) + (multiple-value-bind (longest completions) (funcall fn syntax token package) + (if (> (length longest) 0) + (if (= (length completions) 1) + (replace-symbol-at-mark mark syntax longest) + (progn + (esa:display-message (format nil "Longest is ~a|" longest)) + (let ((selection (menu-choose (mapcar + ;; FIXME: this can + ;; get ugly. + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical))) + (replace-symbol-at-mark mark syntax (or selection + longest))))) + (esa:display-message "No completions found")))) t))) (defun complete-symbol-at-mark (syntax mark)

1 0

[climacs-cvs] CVS climacs
by thenriksen 30 Jul '06

30 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20620 Modified Files: lisp-syntax.lisp Log Message: Guess what - fixed `indices-match-arglist' again. :-) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/29 21:39:50 1.103 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/30 15:04:59 1.104 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX -*- ;;; (c) copyright 2005 by -;;; Robert Strandh (strandh(a)labri.fr) +;;; Robert Strandh (7strandh(a)labri.fr) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -3631,11 +3631,13 @@ (pure-arglist (remove-if #'arglist-keyword-p arglist)) (arg (when (< index (length pure-arglist)) (elt pure-arglist index)))) - (cond ((and (>= index (or (position #'arglist-keyword-p arglist) 0)) - (not (null (rest arg-indices))) - (> (length pure-arglist) - index) - (not (listp (elt pure-arglist index)))) + (cond ((or (and (>= index (or (position-if #'arglist-keyword-p arglist) + (1+ index))) + (not (null (rest arg-indices)))) + (and (not (null (rest arg-indices))) + (> (length pure-arglist) + index) + (not (listp (elt pure-arglist index))))) nil) ((and (not (null arg)) (listp arg)

1 0

[climacs-cvs] CVS climacs
by thenriksen 29 Jul '06

29 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv21434 Modified Files: lisp-syntax.lisp Log Message: `indices-match-arglist' fixed again. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/28 10:37:55 1.102 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/29 21:39:50 1.103 @@ -3631,8 +3631,11 @@ (pure-arglist (remove-if #'arglist-keyword-p arglist)) (arg (when (< index (length pure-arglist)) (elt pure-arglist index)))) - (cond ((and (> index (or (position #'arglist-keyword-p arglist) 0)) - (not (null (rest arg-indices)))) + (cond ((and (>= index (or (position #'arglist-keyword-p arglist) 0)) + (not (null (rest arg-indices))) + (> (length pure-arglist) + index) + (not (listp (elt pure-arglist index)))) nil) ((and (not (null arg)) (listp arg)

1 0

[climacs-cvs] CVS climacs
by thenriksen 28 Jul '06

28 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16960 Modified Files: lisp-syntax.lisp Log Message: Unbreak `goto-location'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/27 19:55:27 1.101 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/28 10:37:55 1.102 @@ -3043,7 +3043,8 @@ (beep) (return-from goto-location)) (switch-to-buffer buffer) - (goto-position (source-position location)))) + (goto-position (point (current-window)) + (char-position (source-position location))))) (defmethod goto-location ((location file-location)) (let ((buffer (find (file-name location) @@ -3055,7 +3056,8 @@ (if buffer (switch-to-buffer buffer) (climacs-commands::find-file (file-name location))) - (goto-position (source-position location)))) + (goto-position (point (current-window)) + (char-position (source-position location))))) ;;; Macroexpansion and evaluation

1 0

[climacs-cvs] CVS climacs
by thenriksen 27 Jul '06

27 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23284 Modified Files: misc-commands.lisp lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: * Changed `form-around' to also select forms with a start or end offset at mark. * Cleaned the symbol-completion code a bit. * Added Indent Line And Complete Symbol command to Lisp syntax (bound to Tab). * Changed default binding of Newline to Newline And Indent in Lisp syntax. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/27 10:39:32 1.20 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/27 19:55:26 1.21 @@ -251,9 +251,12 @@ '((#\i :control))) (define-command (com-newline-and-indent :name t :command-table indent-table) () + "Inserts a newline and indents the new line." (let* ((pane (current-window)) (point (point pane))) (insert-object point #\Newline) + (update-syntax (current-buffer) + (syntax (current-buffer))) (indent-current-line pane point))) (set-key 'com-newline-and-indent --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/25 11:38:05 1.100 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/27 19:55:27 1.101 @@ -1672,9 +1672,10 @@ (with-slots (top bot) pane (loop for child in (children parse-symbol) when (and (start-offset child) - (mark< (start-offset child) bot) (mark> (end-offset child) top)) - do (display-parse-tree child syntax pane)))) + do (if (mark< (start-offset child) bot) + (display-parse-tree child syntax pane) + (return))))) (defmethod display-parse-tree ((parse-symbol error-symbol) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) @@ -1953,7 +1954,9 @@ (defun form-around-in-children (children offset) (loop for child in children if (typep child 'form) - do (cond ((<= (start-offset child) offset (end-offset child)) + do (cond ((or (<= (start-offset child) offset (end-offset child)) + (= offset (end-offset child)) + (= offset (start-offset child))) (return (if (null (first-form (children child))) (when (typep child 'form) child) @@ -1967,8 +1970,8 @@ (defun form-around (syntax offset) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) - (>= offset (end-offset stack-top)) - (<= offset (start-offset stack-top))) + (> offset (end-offset stack-top)) + (< offset (start-offset stack-top))) nil (form-around-in-children (children stack-top) offset)))) @@ -3832,8 +3835,6 @@ ;;; Symbol completion -(defvar *completion-pane* nil) - (defun relevant-keywords (arglist arg-indices) "Return a list of the keyword arguments that it would make sense to use at the position `arg-indices' relative to the @@ -3936,20 +3937,22 @@ (transpose-lists (mapcar #'cdr lists)))))) (defun clear-completions () - (when *completion-pane* - (delete-window *completion-pane*) - (setf *completion-pane* nil))) + (let ((completions-pane + (find "Completions" (esa:windows *application-frame*) + :key #'pane-name + :test #'string=))) + (unless (null completions-pane) + (delete-window completions-pane) + (setf completions-pane nil)))) -(defun show-completions-by-fn (fn symbol package) +(defun find-completion-by-fn (fn symbol package) (esa:display-message (format nil "~a completions" symbol)) (let* ((result (funcall fn symbol (package-name package))) (set (first result)) (longest (second result))) (cond ((<=(length set) 1) (clear-completions)) - (t (let ((stream (or *completion-pane* - (typeout-window "Simple Completions")))) - (setf *completion-pane* stream) + (t (let ((stream (typeout-window "Completions"))) (window-clear stream) (format stream "~{~A~%~}" set)))) (if (not (null longest)) @@ -3957,9 +3960,9 @@ (esa:display-message "No completions found")) longest)) -(defun show-completions (syntax token package) +(defun find-completion (syntax token package) (let ((symbol-name (token-string syntax token))) - (show-completions-by-fn + (find-completion-by-fn #'(lambda (&rest args) (find-if #'identity (list @@ -3974,19 +3977,47 @@ :key #'first)) symbol-name package))) -(defun show-fuzzy-completions (syntax symbol-name package) - (esa:display-message (format nil "~a completions" symbol-name)) - (let* ((set (fuzzy-completions (get-usable-image syntax) symbol-name package 10)) - (best (caar set))) - (cond ((<= (length set) 1) - (clear-completions)) - (t (let ((stream (or *completion-pane* - (typeout-window "Simple Completions")))) - (setf *completion-pane* stream) - (window-clear stream) - (loop for completed-string in set - do (format stream "~{~A ~}~%" completed-string))))) - (esa:display-message (if (not (null best)) - (format nil "Best is ~a|" best) - "No fuzzy completions found")) - best)) +(defun find-fuzzy-completion (syntax token package) + (let ((symbol-name (token-string syntax token))) + (esa:display-message (format nil "~a completions" symbol-name)) + (let* ((set (fuzzy-completions (get-usable-image syntax) symbol-name package 10)) + (best (caar set))) + (cond ((<= (length set) 1) + (clear-completions)) + (t (let ((stream (typeout-window "Completions"))) + (window-clear stream) + (loop for completed-string in set + do (format stream "~{~A ~}~%" completed-string))))) + (esa:display-message (if (not (null best)) + (format nil "Best is ~a|" best) + "No fuzzy completions found")) + best))) + +(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completion)) + "Attempt to find and complete the symbol at `mark' using the + function `fn' to get the list of completions. If the completion + is ambiguous, a list of possible completions will be + displayed. If no symbol can be found at `mark', return nil." + (let ((token (form-around syntax (offset mark)))) + (when (and (not (null token)) + (typep token 'complete-token-lexeme) + (not (= (start-offset token) + (offset mark)))) + (with-syntax-package syntax mark (package) + (let ((completion (funcall fn syntax token package))) + (unless (= (length completion) 0) + (replace-symbol-at-mark mark syntax completion)))) + t))) + +(defun complete-symbol-at-mark (syntax mark) + "Attempt to find and complete the symbol at `mark'. If the + completion is ambiguous, a list of possible completions will be + displayed. If no symbol can be found at `mark', return nil." + (complete-symbol-at-mark-with-fn syntax mark)) + +(defun fuzzily-complete-symbol-at-mark (syntax mark) + "Attempt to find and complete the symbol at `mark' using fuzzy + completion. If the completion is ambiguous, a list of possible + completions will be displayed. If no symbol can be found at + `mark', return nil." + (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completion)) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 13:24:40 1.12 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/27 19:55:27 1.13 @@ -253,14 +253,8 @@ (let* ((pane (current-window)) (buffer (buffer pane)) (syntax (syntax buffer)) - (mark (point pane)) - (token (symbol-at-mark mark - syntax))) - (when token - (with-syntax-package syntax mark (package) - (let ((completion (show-completions syntax token package))) - (unless (= (length completion) 0) - (replace-symbol-at-mark mark syntax completion))))))) + (mark (point pane))) + (complete-symbol-at-mark syntax mark))) (define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () "Attempt to fuzzily complete the abbreviation at mark. @@ -271,14 +265,24 @@ (let* ((pane (current-window)) (buffer (buffer pane)) (syntax (syntax buffer)) - (mark (mark pane)) - (name (symbol-name-at-mark mark - syntax))) - (when name - (with-syntax-package syntax mark (package) - (let ((completion (show-fuzzy-completions syntax name package))) - (unless (= (length completion) 0) - (replace-symbol-at-mark mark syntax completion))))))) + (mark (point pane))) + (fuzzily-complete-symbol-at-mark syntax mark))) + +(define-command (com-indent-line-and-complete-symbol :name t :command-table lisp-table) () + "Indents the current line and performs symbol completion. +First indents the line. If the line was already indented, +completes the symbol. If there's no symbol at the point, shows +the arglist for the most recently enclosed operator." + (let* ((pane (current-window)) + (point (point pane)) + (old-offset (offset point))) + (indent-current-line pane point) + (when (= old-offset + (offset point)) + (let* ((buffer (buffer pane)) + (syntax (syntax buffer))) + (or (complete-symbol-at-mark syntax point) + (show-arglist-for-form-at-mark point syntax)))))) (define-presentation-to-command-translator lookup-symbol-arglist (symbol com-lookup-arglist lisp-table @@ -366,11 +370,11 @@ 'lisp-table '((#\c :control) (#\k :control))) -(esa:set-key 'com-compile-file - 'lisp-table - '((#\c :control) (#\k :meta))) +(esa:set-key 'com-compile-file + 'lisp-table + '((#\c :control) (#\k :meta))) -(esa:set-key `(com-edit-this-definition) +(esa:set-key 'com-edit-this-definition 'lisp-table '((#\. :meta))) @@ -382,7 +386,7 @@ 'lisp-table '((#\c :control) (#\d :control) (#\h))) -(esa:set-key `(com-lookup-arglist-for-this-symbol) +(esa:set-key 'com-lookup-arglist-for-this-symbol 'lisp-table '((#\c :control) (#\d :control) (#\a))) @@ -398,3 +402,10 @@ 'lisp-table '((#\c :control) (#\i :meta))) +(esa:set-key 'com-indent-line-and-complete-symbol + 'lisp-table + '((#\Tab))) + +(esa:set-key 'climacs-commands::com-newline-and-indent + 'lisp-table + '(#\Newline)) \ No newline at end of file

1 0

[climacs-cvs] CVS climacs
by thenriksen 27 Jul '06

27 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3682 Modified Files: gui.lisp Log Message: Changed `typeout-window' to return the existing pane if a pane with the specified label already exists. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/25 11:38:05 1.225 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/27 14:35:35 1.226 @@ -444,7 +444,7 @@ (defun make-typeout-constellation (&optional label) (let* ((typeout-pane (make-pane 'typeout-pane :foreground *fg-color* :background *bg-color* - :width 900 :height 400 :display-time nil)) + :width 900 :height 400 :display-time nil :name label)) (label (make-pane 'label-pane :label label)) (vbox @@ -453,16 +453,20 @@ (values vbox typeout-pane))) (defun typeout-window (&optional (label "Typeout") (pane (current-window))) + "Get a typeout pane labelled `label'. If a pane with this label +already exists, it will be returned. Otherwise, a new pane will +be created." (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation label) - (let* ((current-window pane) - (constellation-root (find-parent current-window))) - (push new-pane (windows *application-frame*)) - (other-window) - (replace-constellation constellation-root vbox t) - (full-redisplay current-window) - new-pane)))) + (or (find label (windows *application-frame*) :key #'pane-name) + (multiple-value-bind (vbox new-pane) (make-typeout-constellation label) + (let* ((current-window pane) + (constellation-root (find-parent current-window))) + (push new-pane (windows *application-frame*)) + (other-window) + (replace-constellation constellation-root vbox t) + (full-redisplay current-window) + new-pane))))) (defun delete-window (&optional (window (current-window))) (unless (null (cdr (windows *application-frame*)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 27 Jul '06

27 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26713 Modified Files: pane.lisp Log Message: Updated the undo protocol documentation (and added missing reader to the implementation). --- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/24 13:24:40 1.46 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/27 13:58:57 1.47 @@ -60,7 +60,7 @@ ((buffer :initarg :buffer))) (defclass simple-undo-record (climacs-undo-record) - ((offset :initarg :offset))) + ((offset :initarg :offset :reader undo-offset))) (defclass insert-record (simple-undo-record) ((objects :initarg :objects)))

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 27 Jul '06

27 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv26713/Doc Modified Files: climacs-internals.texi Log Message: Updated the undo protocol documentation (and added missing reader to the implementation). --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/07/27 10:39:32 1.21 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/07/27 13:58:57 1.22 @@ -1771,7 +1771,7 @@ The base class for all undo trees. @end deftp -@deftp {protocol class} undo-record +@deftp {protocol class} standard-undo-record The base class for all undo records. @@ -1851,36 +1851,37 @@ @section How the buffer handles undo -@deftp {class} undoable-buffer +@deftp {class} undo-mixin -This is a subclass of standard-buffer. Instantiating this class -creates an empy undo-tree for the buffer. +This is a mixin class that buffer classes can inherit from. It contains +an undo tree, an undo accumulator and a flag specifyng whether or not it +is currently performing undo. The undo tree and undo accumulators are +initially empty. @end deftp -@deffn {generic function} undo-tree undoable-buffer +@deffn {generic function} undo-tree undo-mixin -Return the undo-tree of the buffer. +A slot reader. Returns the undo-tree of the buffer. @end deffn -Undo is implemented as :after methods on, insert-buffer-object, +Undo is implemented as :before methods on, insert-buffer-object, insert-buffer-sequence and delete-buffer-range specialized on -undoable-buffer. +undo-mixin. -@deftp {special variable} *undo-accumulate* - -This variable is initially nil (the empty list). The :after methods -on insert-buffer-object, insert-buffer-sequence, and -delete-buffer-range push undo records on to this list. -@end deftp +@deffn {generic-function} undo-accumulate undo-mixin +A slot accessor. This list returned by thus function is initially nil +(the empty list). The :before methods on insert-buffer-object, +insert-buffer-sequence, and delete-buffer-range push undo records on to +this list. +@end deffn -@deftp {special variable} *performing-undo* +@deffn {generic-function} performing-undo undo-mixin -This variable is initially nil. The :after methods on +A slot accessor. This slot is initially nil. The :before methods on insert-buffer-object, insert-buffer-sequence, and delete-buffer-range -push undo records onto *undo-accumulate* only if *performing-undo* is -nil so that no undo information is added as a result of an undo -operation. -@end deftp +push undo records onto the undo accumulator only if this slot is nil so +that no undo information is added as a result of an undo operation. +@end deffn Three subclasses `insert-record', `delete-record', and `compound-record' of undo-record are used. An insert record stores a @@ -1888,20 +1889,21 @@ stores a position and the length of the sequence to be deleted, and a compound record stores a list of other undo records. -The :after methods on insert-buffer-object and insert-buffer-sequence -push a record of type delete-record onto *undo-accumulate*, and the -:after method on delete-buffer-range pushes a record of type -insert-record onto *undo-accumulate*. - -@deffn {macro} with-undo buffer &body body - -This macro first binds *undo-accumulate* to nil. Then it executes -the forms of body. Finally, it calls add-undo with an undo record -and the undo tree of the buffer. If *undo-accumulate* contains a -single undo record, it is passed as is to add-undo. If it contains -several undo records, a compound undo record is constructed out of -the list and passed to add-undo. Finally, if *undo-accumulate* is -nil, add-undo is not called at all. +The :before methods on insert-buffer-object and insert-buffer-sequence +push a record of type delete-record onto the undo accumulator for the +buffer, and the :before method on delete-buffer-range pushes a record of +type insert-record onto the undo accumulator. + +@deffn {macro} with-undo (get-buffers-exp) &body body + +This macro executes the forms of `body', registering changes made to the +list of buffers retrieved by evaluating `get-buffers-exp'. When `body' +has run, for each buffer it will call add-undo with an undo record and +the undo tree of the buffer. If the changes done by `body' to the +buffer has resulted in only a single undo record, it is passed as is to +add-undo. If it contains several undo records, a compound undo record +is constructed out of the list and passed to add-undo. Finally, if the +buffer has no undo records, add-undo is not called at all. @end deffn To avoid storing an undo record for each object that is inserted, @@ -1909,24 +1911,24 @@ the sequence in the last delete-record. The method on flip-undo-record specialized on insert-record binds -*performing-undo* to t, inserts the sequence of objects in the -buffer, and calls change-class to convert the insert-record to a +performing-undo for the buffer to t, inserts the sequence of objects in +the buffer, and calls change-class to convert the insert-record to a delete-record, giving it a the length of the stored sequence. The method on flip-undo-record specialized on delete-record binds -*performing-undo* to t, deletes the range from the buffer, and calls -change-class to convert the delete-record to an insert-record, giving -it the sequence at the stored offset in the buffer with the specified -length. +performing-undo for the buffer to t, deletes the range from the buffer, +and calls change-class to convert the delete-record to an insert-record, +giving it the sequence at the stored offset in the buffer with the +specified length. The method on flip-undo-record specialized on compound-record binds -*performing-undo* to t, recursively calls flip-undo-record on each -element of the list of undo records, and finally destructively +performing-undo for the buffer to t, recursively calls flip-undo-record +on each element of the list of undo records, and finally destructively reverses the list. -@deftp {class} buffer-undo-record +@deftp {class} climacs-undo-record -A subclass of undo-record. +A subclass of standard-undo-record. @end deftp @deftp {initarg} :buffer @@ -1934,6 +1936,11 @@ The buffer to which the record belongs. @end deftp +@deftp {class} simple-undo-record + +A subclass of climacs-undo-record. +@end deftp + @deftp {initarg} :offset This initarg is mandatory and supplies the offset that determines the @@ -1960,7 +1967,7 @@ @deftp {class} insert-record -A subclass of buffer-undo-record. Whenever objects are deleted, the +A subclass of simple-undo-record. Whenever objects are deleted, the sequence of objectgs is stored in an insert record containing a mark. @end deftp @@ -1972,11 +1979,13 @@ @deftp {class} compound-record -A subclass of buffer-undo-record. This record simply contains a list +A subclass of simple-undo-record. This record simply contains a list of other records. @end deftp @deftp {initarg} :records + +A list of output records. @end deftp @chapter Kill Ring Protocol

1 0

[climacs-cvs] CVS climacs
by thenriksen 27 Jul '06

27 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18840 Modified Files: search-commands.lisp packages.lisp misc-commands.lisp kill-ring.lisp climacs.asd buffer-test.lisp Added Files: kill-ring-test.lisp Log Message: Updated the kill ring protocol to signal a condition if a yank operation is attempted on an empty kill ring, updated the kill ring documentation, added kill ring tests to the test suite. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/25 11:38:05 1.11 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/27 10:39:32 1.12 @@ -179,7 +179,7 @@ (let* ((pane (current-window)) (states (isearch-states pane)) (yank (handler-case (kill-ring-yank *kill-ring*) - (flexichain:at-end-error () + (empty-kill-ring () ""))) (string (concatenate 'string (search-string (first states)) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/25 11:38:05 1.108 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/27 10:39:32 1.109 @@ -66,6 +66,7 @@ (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) (:export #:kill-ring + #:empty-kill-ring #:kill-ring-length #:kill-ring-max-size #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/25 11:38:05 1.19 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/27 10:39:32 1.20 @@ -459,7 +459,7 @@ (define-command (com-yank :name t :command-table editing-table) () "Insert the objects most recently added to the kill ring at point." (handler-case (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)) - (flexichain:at-end-error () + (empty-kill-ring () (display-message "Kill ring is empty")))) (set-key 'com-yank @@ -503,7 +503,7 @@ (delete-range point (* -1 (length last-yank))) (rotate-yank-position *kill-ring*))) (insert-sequence point (kill-ring-yank *kill-ring*))) - (flexichain:at-end-error () + (empty-kill-ring () (display-message "Kill ring is empty")))) (set-key 'com-rotate-yank --- /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/24 16:33:16 1.10 +++ /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/27 10:39:32 1.11 @@ -36,6 +36,14 @@ :accessor append-next-p)) (:documentation "A class for all kill rings")) +(define-condition empty-kill-ring (simple-error) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream "The kill ring is empty"))) + (:documentation "This condition is signaled whenever a yank + operation is performed on an empty kill ring.")) + (defmethod initialize-instance :after((kr kill-ring) &rest args) "Adds in the yankpoint" (declare (ignore args)) @@ -82,10 +90,13 @@ is empty a new entry is pushed.")) (defgeneric kill-ring-yank (kr &optional reset) - (:documentation "Returns the vector of objects currently pointed to - by the cursor. If reset is T, a call to - reset-yank-position is called befor the object is - yanked. The default for reset is NIL")) + (:documentation "Returns the vector of objects currently + pointed to by the cursor. If reset is T, a + call to reset-yank-position is called before + the object is yanked. The default for reset + is NIL. If the kill ring is empty, a + condition of type `empty-kill-ring' is + signalled.")) (defmethod kill-ring-length ((kr kill-ring)) (nb-elements (kill-ring-chain kr))) @@ -117,6 +128,7 @@ (setf (cursor-pos curs) pos)))) (defmethod kill-ring-standard-push ((kr kill-ring) vector) + (check-type vector vector) (cond ((append-next-p kr) (kill-ring-concatenating-push kr vector) (setf (append-next-p kr) nil)) @@ -130,25 +142,31 @@ (reset-yank-position kr)))) (defmethod kill-ring-concatenating-push ((kr kill-ring) vector) + (check-type vector vector) (let ((chain (kill-ring-chain kr))) (if (zerop (kill-ring-length kr)) (push-start chain vector) (push-start chain (concatenate 'vector (pop-start chain) - vector)))) - (reset-yank-position kr)) + vector))) + (reset-yank-position kr))) (defmethod kill-ring-reverse-concatenating-push ((kr kill-ring) vector) + (check-type vector vector) (let ((chain (kill-ring-chain kr))) (if (zerop (kill-ring-length kr)) (push-start chain vector) (push-start chain (concatenate 'vector vector - (pop-start chain)))))) + (pop-start chain)))) + (reset-yank-position kr))) (defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil)) + (assert (plusp (kill-ring-length kr)) + () + (make-condition 'empty-kill-ring)) (if reset (reset-yank-position kr)) (element> (kill-ring-cursor kr))) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/25 11:38:05 1.49 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/27 10:39:32 1.50 @@ -114,6 +114,7 @@ ((:file "rt" :pathname #p"testing/rt.lisp") (:file "buffer-test" :depends-on ("rt")) (:file "base-test" :depends-on ("rt" "buffer-test")) + (:file "kill-ring-test" :depends-on ("buffer-test")) (:module "cl-automaton" :depends-on ("rt") --- /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/24 13:24:40 1.23 +++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/27 10:39:32 1.24 @@ -5,7 +5,8 @@ (cl:defpackage :climacs-tests (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion - :climacs-editing :automaton :climacs-core)) + :climacs-editing :automaton :climacs-core + :climacs-kill-ring)) (cl:in-package :climacs-tests) --- /project/climacs/cvsroot/climacs/kill-ring-test.lisp 2006/07/27 10:39:33 NONE +++ /project/climacs/cvsroot/climacs/kill-ring-test.lisp 2006/07/27 10:39:33 1.1 ;;; (c) Copyright 2006 by Troels Henriksen (athas(a)sigkill.dk) ;;; (in-package :climacs-tests) (deftest kill-ring-sizing.test-1 (let* ((random-size (random 20)) (instance (make-instance 'kill-ring :max-size random-size))) (eql (kill-ring-max-size instance) random-size)) t) (deftest kill-ring-sizing.test-2 (let* ((random-size (random 20)) (instance (make-instance 'kill-ring :max-size random-size))) (setf (kill-ring-max-size instance) (* random-size 2)) (eql (kill-ring-max-size instance) (* random-size 2))) t) (deftest kill-ring-sizing.test-3 (let* ((random-size (1+ (random 20))) (instance (make-instance 'kill-ring :max-size random-size))) (not (eql (kill-ring-max-size instance) (kill-ring-length instance)))) t) (deftest kill-ring-standard-push.test-1 (let* ((random-size (min 3 (random 20))) (instance (make-instance 'kill-ring :max-size random-size))) (kill-ring-standard-push instance #(#\A)) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\C)) (kill-ring-length instance)) 3) (deftest kill-ring-standard-push.test-2 (let* ((random-size (1+ (random 20))) (instance (make-instance 'kill-ring :max-size random-size))) (handler-case (kill-ring-standard-push instance nil) (type-error () t))) t) (deftest kill-ring-standard-push.test-3 (let* ((instance (make-instance 'kill-ring :max-size 3))) (kill-ring-standard-push instance #(#\A)) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\C)) (kill-ring-standard-push instance #(#\D)) (kill-ring-standard-push instance #(#\E)) (values (kill-ring-yank instance) (progn (rotate-yank-position instance) (kill-ring-yank instance)) (progn (rotate-yank-position instance) (kill-ring-yank instance)))) #(#\E) #(#\D) #(#\C)) (deftest kill-ring-concatenating-push.test-1 (let* ((instance (make-instance 'kill-ring :max-size 3))) (kill-ring-standard-push instance #(#\A)) (kill-ring-concatenating-push instance #(#\B)) (kill-ring-yank instance)) #(#\A #\B)) (deftest kill-ring-concatenating-push.test-2 (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\Space)) (kill-ring-standard-push instance #(#\A)) (rotate-yank-position instance 2) (kill-ring-concatenating-push instance #(#\B #\C)) (kill-ring-yank instance)) #(#\A #\B #\C)) (deftest kill-ring-reverse-concatenating-push.test-1 (let* ((instance (make-instance 'kill-ring :max-size 3))) (kill-ring-standard-push instance #(#\A)) (kill-ring-reverse-concatenating-push instance #(#\B)) (kill-ring-yank instance)) #(#\B #\A)) (deftest kill-ring-reverse-concatenating-push.test-2 (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\B)) (kill-ring-standard-push instance #(#\Space)) (kill-ring-standard-push instance #(#\A)) (rotate-yank-position instance 2) (kill-ring-reverse-concatenating-push instance #(#\B #\C)) (kill-ring-yank instance)) #(#\B #\C #\A)) (deftest kill-ring-yank.test-1 (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\A)) (kill-ring-yank instance)) #(#\A)) (deftest kill-ring-yank.test-2 (let* ((instance (make-instance 'kill-ring :max-size 5))) (kill-ring-standard-push instance #(#\A)) (values (kill-ring-yank instance) (kill-ring-yank instance))) #(#\A) #(#\A)) (deftest kill-ring-yank.test-3 (let* ((instance (make-instance 'kill-ring :max-size 5))) (handler-case (kill-ring-yank instance) (empty-kill-ring () t))) t)

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 27 Jul '06

27 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv18840/Doc Modified Files: climacs-internals.texi Log Message: Updated the kill ring protocol to signal a condition if a yank operation is attempted on an empty kill ring, updated the kill ring documentation, added kill ring tests to the test suite. --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/03/26 16:40:00 1.20 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/07/27 10:39:32 1.21 @@ -1999,9 +1999,12 @@ latter method is refered to as a ``concatenating push''. For data retrievial the kill ring class provides a ``yank point'' which -allows focus to be shifted from the SORP to other positions within the kill ring. -The yank point is limited to two types of motition, one being a rotation away from the SORP -and the other being an immediate return or ``reset'' to the start position. +allows focus to be shifted from the SORP to other positions within the +kill ring. The yank point is limited to two types of motition, one +being a rotation away from the SORP and the other being an immediate +return or ``reset'' to the start position. When the kill ring is +modified, for example by a push, the yank point will be reset to the +start position. @section General @@ -2038,7 +2041,13 @@ @deffn {generic function} kill-ring-concatenating-push kill-ring vector Concatenates the contents of vector onto the end of the contents of the current top of the kill-ring. If the kill-ring is empty, a new -entry is pushed.. +entry is pushed. +@end deffn + +@deffn {generic function} kill-ring-reverse-concatenating-push kill-ring vector +Concatenates the contents of vector onto the front of the current +contents of the top of the kill ring. If the kill ring is empty a new +entry is pushed. @end deffn @deffn {generic function} rotate-yank-position kill-ring &optional times @@ -2053,9 +2062,10 @@ @end deffn @deffn {generic function} kill-ring-yank kill-ring &optional reset -Returns the vector of objects currently pointed to by the cursor. If reset is T, then a -call to reset-yank-position is called before the object is yanked. The default for reset -is NIL. +Returns the vector of objects currently pointed to by the cursor. If +reset is T, then a call to reset-yank-position is called before the +object is yanked. The default for reset is NIL. If the kill ring is +empty, a condition of type `empty-kill-ring' is signalled. @end deffn @section Implementation

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs July 2006