July 2006 - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[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

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

25 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1535 Modified Files: slidemacs-gui.lisp search-commands.lisp packages.lisp motion.lisp misc-commands.lisp lisp-syntax.lisp gui.lisp file-commands.lisp core.lisp climacs.asd Log Message: More refactoring of stuff out from CLIMACS-GUI to CLIMACS-CORE and CLIMACS-COMMANDS. More reusable functions have been moved from the *-commands.lisp files to core.lisp. --- /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/03/03 19:38:57 1.22 +++ /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/07/25 11:38:05 1.23 @@ -530,11 +530,11 @@ (full-redisplay (climacs-gui::current-window))) (define-command (com-first-talking-point :name t :command-table slidemacs-table) () - (climacs-gui::com-beginning-of-buffer) + (climacs-commands::com-beginning-of-buffer) (com-next-talking-point)) (define-command (com-last-talking-point :name t :command-table slidemacs-table) () - (climacs-gui::com-end-of-buffer) + (climacs-commands::com-end-of-buffer) (com-previous-talking-point)) (define-command (com-flip-slidemacs-syntax :name t :command-table slidemacs-table) () --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 16:33:16 1.10 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/25 11:38:05 1.11 @@ -28,37 +28,6 @@ (in-package :climacs-commands) -(defun display-string (string) - (with-output-to-string (result) - (loop for char across string - do (cond ((graphic-char-p char) (princ char result)) - ((char= char #\Space) (princ char result)) - (t (prin1 char result)))))) - -(defun object-equal (x y) - "Case insensitive equality that doesn't require characters" - (if (characterp x) - (and (characterp y) (char-equal x y)) - (eql x y))) - -(defun object= (x y) - "Case sensitive equality that doesn't require characters" - (if (characterp x) - (and (characterp y) (char= x y)) - (eql x y))) - -(defun no-upper-p (string) - "Does STRING contain no uppercase characters" - (notany #'upper-case-p string)) - -(defun case-relevant-test (string) - "Returns a test function based on the search-string STRING. -If STRING contains no uppercase characters the test is case-insensitive, -otherwise it is case-sensitive." - (if (no-upper-p string) - #'object-equal - #'object=)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; String search --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 16:33:16 1.107 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/25 11:38:05 1.108 @@ -329,16 +329,14 @@ #:point #:syntax #:mark + #:buffers #:insert-character - #:switch-to-buffer - #:make-buffer - #:erase-buffer - #:buffer-pane-p #:display-window #:split-window #:typeout-window #:delete-window #:other-window + #:buffer-pane-p ;; Some configuration variables #:*bg-color* @@ -368,8 +366,14 @@ (defpackage :climacs-core (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring - :climacs-editing :climacs-gui :clim :climacs-abbrev) - (:export #:goto-position + :climacs-editing :climacs-gui :clim :climacs-abbrev :esa) + (:export #:display-string + #:object-equal + #:object= + #:no-upper-p + #:case-relevant-test + + #:goto-position #:goto-line #:possibly-fill-line @@ -384,7 +388,23 @@ #:indent-region #:fill-line #:fill-region - #:indent-line #:delete-indentation) + #:indent-line #:delete-indentation + + #:set-syntax + + #:switch-to-buffer + #:make-buffer + #:erase-buffer + #:kill-buffer + + #:filepath-filename + #:evaluate-attributes-line + #:directory-pathname-p + #:find-file + #:directory-of-buffer + #:set-visited-file-name + #:check-file-times + #:save-buffer) (:documentation "Package for editor functionality that is syntax-aware, but yet not specific to certain syntaxes. Contains stuff like indentation, filling and other @@ -424,7 +444,8 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing) + :climacs-syntax :flexichain :climacs-pane :climacs-gui + :climacs-motion :climacs-editing :climacs-core) (:export #:lisp-string #:edit-definition)) --- /project/climacs/cvsroot/climacs/motion.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/motion.lisp 2006/07/25 11:38:05 1.2 @@ -88,7 +88,7 @@ (defun beep-limit-action (mark original-offset remaining unit syntax) (declare (ignore mark original-offset remaining unit syntax)) - (beep) + (clim:beep) nil) (defun revert-limit-action (mark original-offset remaining unit syntax) --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 16:33:16 1.18 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/25 11:38:05 1.19 @@ -445,24 +445,6 @@ 'marking-table '((#\x :control) (#\x :control))) -(defgeneric set-syntax (buffer syntax)) - -(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax)) - (setf (syntax buffer) syntax)) - -;;FIXME - what should this specialise on? -(defmethod set-syntax ((buffer climacs-buffer) syntax) - (set-syntax buffer (make-instance syntax :buffer buffer))) - -(defmethod set-syntax ((buffer climacs-buffer) (syntax string)) - (let ((syntax-class (syntax-from-name syntax))) - (cond (syntax-class - (set-syntax buffer (make-instance syntax-class - :buffer buffer))) - (t - (beep) - (display-message "No such syntax: ~A." syntax))))) - (define-command (com-set-syntax :name t :command-table buffer-table) ((syntax 'syntax :prompt "Name of syntax")) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 20:52:23 1.99 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/25 11:38:05 1.100 @@ -52,7 +52,7 @@ (make-command-table 'lisp-table :errorp nil - :inherit-from '(climacs-gui::global-climacs-table)) + :inherit-from '(global-climacs-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -97,6 +97,9 @@ (or (slot-value syntax 'base) *read-base*))) +(defmethod (setf base) (base (syntax lisp-syntax)) + (setf (slot-value syntax 'base) base)) + (define-option-for-syntax lisp-syntax "Package" (syntax package-name) (let ((specified-package (find-package package-name))) (setf (option-specified-package syntax) (or specified-package package-name)))) @@ -104,7 +107,9 @@ (define-option-for-syntax lisp-syntax "Base" (syntax base) (let ((integer-base (parse-integer base :junk-allowed t))) (when integer-base - (setf (base syntax) integer-base)))) + (if (typep integer-base '(integer 2 36)) + (setf (base syntax) integer-base) + (esa:display-message "Invalid base specified: outside the interval 2 to 36."))))) (defmethod initialize-instance :after ((syntax lisp-syntax) &rest args) (declare (ignore args)) @@ -3010,7 +3015,7 @@ (def-print-for-menu note-compiler-note "Note" +brown+) (defun show-notes (notes buffer-name definition) - (let ((stream (climacs-gui::typeout-window + (let ((stream (typeout-window (format nil "~10TCompiler Notes: ~A ~A" buffer-name definition)))) (loop for note in notes do (with-output-as-presentation (stream note 'compiler-note) @@ -3028,33 +3033,27 @@ (defmethod goto-location ((location buffer-location)) (let ((buffer (find (buffer-name location) - (climacs-gui::buffers *application-frame*) + (buffers *application-frame*) :test #'string= :key #'name))) (unless buffer (esa:display-message "No buffer ~A" (buffer-name location)) (beep) (return-from goto-location)) - (climacs-gui::switch-to-buffer buffer) + (switch-to-buffer buffer) (goto-position (source-position location)))) (defmethod goto-location ((location file-location)) (let ((buffer (find (file-name location) - (climacs-gui::buffers *application-frame*) + (buffers *application-frame*) :test #'string= :key #'(lambda (buffer) (let ((path (filepath buffer))) (when path (namestring path))))))) (if buffer - (climacs-gui::switch-to-buffer buffer) - (climacs-gui::find-file (file-name location))) + (switch-to-buffer buffer) + (climacs-commands::find-file (file-name location))) (goto-position (source-position location)))) -(defgeneric goto-position (position)) - -(defmethod goto-position ((position char-position)) - (climacs-gui::goto-position (climacs-gui::point (climacs-gui::current-window)) - (char-position position))) - ;;; Macroexpansion and evaluation (defun macroexpand-token (syntax token &optional (all nil)) @@ -3067,12 +3066,12 @@ all)) (expansion-string (with-output-to-string (s) (pprint expansion s)))) - (let ((buffer (climacs-gui::switch-to-buffer "*Macroexpansion*"))) - (climacs-gui::set-syntax buffer "Lisp")) - (let ((point (point (climacs-gui::current-window))) + (let ((buffer (switch-to-buffer "*Macroexpansion*"))) + (set-syntax buffer "Lisp")) + (let ((point (point (current-window))) (header-string (one-line-ify (subseq string 0 (min 40 (length string)))))) - (climacs-gui::end-of-buffer point) + (end-of-buffer point) (unless (beginning-of-buffer-p point) (insert-object point #\Newline)) (insert-sequence point @@ -3130,7 +3129,7 @@ (defun compile-file-interactively (buffer &optional load-p) (when (and (needs-saving buffer) (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) - (climacs-gui::save-buffer buffer)) + (save-buffer buffer)) (with-syntax-package (syntax buffer) 0 (package) (let ((*read-base* (base (syntax buffer)))) (multiple-value-bind (result notes) @@ -3745,9 +3744,9 @@ (let* ((offset+buffer (pop *find-definition-stack*)) (offset (first offset+buffer)) (buffer (second offset+buffer))) - (if (find buffer (climacs-gui::buffers *application-frame*)) - (progn (climacs-gui::switch-to-buffer buffer) - (climacs-gui::goto-position (point (climacs-gui::current-window)) offset)) + (if (find buffer (buffers *application-frame*)) + (progn (switch-to-buffer buffer) + (goto-position (point (current-window)) offset)) (pop-find-definition-stack))))) ;; KLUDGE: We need to put more info in the definition objects to begin @@ -3780,7 +3779,7 @@ (goto-definition symbol definitions)))))) (defun goto-definition (name definitions) - (let* ((pane (climacs-gui:current-window)) + (let* ((pane (current-window)) (buffer (buffer pane)) (point (point pane)) (offset (offset point))) @@ -3820,7 +3819,7 @@ (with-drawing-options (stream :ink +dark-blue+ :text-style (make-text-style :fixed nil nil)) (princ (dspec item) stream)))) - (let ((stream (climacs-gui::typeout-window + (let ((stream (typeout-window (format nil "~10T~A ~A" type symbol)))) (loop for xref in xrefs do (with-output-as-presentation (stream xref 'xref) @@ -3938,7 +3937,7 @@ (defun clear-completions () (when *completion-pane* - (climacs-gui::delete-window *completion-pane*) + (delete-window *completion-pane*) (setf *completion-pane* nil))) (defun show-completions-by-fn (fn symbol package) @@ -3949,7 +3948,7 @@ (cond ((<=(length set) 1) (clear-completions)) (t (let ((stream (or *completion-pane* - (climacs-gui::typeout-window "Simple Completions")))) + (typeout-window "Simple Completions")))) (setf *completion-pane* stream) (window-clear stream) (format stream "~{~A~%~}" set)))) @@ -3982,7 +3981,7 @@ (cond ((<= (length set) 1) (clear-completions)) (t (let ((stream (or *completion-pane* - (climacs-gui::typeout-window "Simple Completions")))) + (typeout-window "Simple Completions")))) (setf *completion-pane* stream) (window-clear stream) (loop for completed-string in set --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 16:33:16 1.224 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/25 11:38:05 1.225 @@ -214,24 +214,6 @@ ((type modified) record stream state) nil) -(define-command (com-toggle-read-only :name t :command-table base-table) - ((buffer 'buffer)) - (setf (read-only-p buffer) (not (read-only-p buffer)))) -(define-presentation-to-command-translator toggle-read-only - (read-only com-toggle-read-only base-table - :gesture :menu) - (object) - (list object)) - -(define-command (com-toggle-modified :name t :command-table base-table) - ((buffer 'buffer)) - (setf (needs-saving buffer) (not (needs-saving buffer)))) -(define-presentation-to-command-translator toggle-modified - (modified com-toggle-modified base-table - :gesture :menu) - (object) - (list object)) - (defun display-info (frame pane) (let* ((master-pane (master-pane pane)) (buffer (buffer master-pane)) @@ -352,27 +334,6 @@ 'base-table '((#\l :control))) -(defun load-file (file-name) - (cond ((directory-pathname-p file-name) - (display-message "~A is a directory name." file-name) - (beep)) - (t - (cond ((probe-file file-name) - (load file-name)) - (t - (display-message "No such file: ~A" file-name) - (beep)))))) - -(define-command (com-load-file :name t :command-table base-table) () - "Prompt for a filename and CL:LOAD that file. -Signals and error if the file does not exist." - (let ((filepath (accept 'pathname :prompt "Load File"))) - (load-file filepath))) - -(set-key 'com-load-file - 'base-table - '((#\c :control) (#\l :control))) - (define-command com-self-insert ((count 'integer)) (loop repeat count do (insert-character *current-gesture*))) @@ -387,7 +348,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Pane/buffer functions +;;; Pane functions (defun replace-constellation (constellation additional-constellation vertical-p) (let* ((parent (sheet-parent constellation)) @@ -530,12 +491,6 @@ (list first second other) (list first other))))))) -(defun make-buffer (&optional name) - (let ((buffer (make-instance 'climacs-buffer))) - (when name (setf (name buffer) name)) - (push buffer (buffers *application-frame*)) - buffer)) - (defun other-window (&optional pane) (if (and pane (find pane (windows *application-frame*))) (setf (windows *application-frame*) @@ -550,132 +505,6 @@ (other-window) (setf *standard-output* (car (windows *application-frame*))))) -(defgeneric erase-buffer (buffer)) - -(defmethod erase-buffer ((buffer string)) - (let ((b (find buffer (buffers *application-frame*) - :key #'name :test #'string=))) - (when b (erase-buffer b)))) - -(defmethod erase-buffer ((buffer climacs-buffer)) - (let* ((point (point buffer)) - (mark (clone-mark point))) - (beginning-of-buffer mark) - (end-of-buffer point) - (delete-region mark point))) - -(define-presentation-method present (object (type buffer) - stream - (view textual-view) - &key acceptably for-context-type) - (declare (ignore acceptably for-context-type)) - (princ (name object) stream)) - -(define-presentation-method accept - ((type buffer) stream (view textual-view) &key (default nil defaultp) - (default-type type)) - (multiple-value-bind (object success string) - (complete-input stream - (lambda (so-far action) - (complete-from-possibilities - so-far (buffers *application-frame*) '() :action action - :name-key #'name - :value-key #'identity)) - :partial-completers '(#\Space) - :allow-any-input t) - (cond (success - (values object type)) - ((and (zerop (length string)) defaultp) - (values default default-type)) - (t (values string 'string))))) - -(defgeneric switch-to-buffer (buffer)) - -(defmethod switch-to-buffer ((buffer climacs-buffer)) - (let* ((buffers (buffers *application-frame*)) - (position (position buffer buffers)) - (pane (current-window))) - (when position - (setf buffers (delete buffer buffers))) - (push buffer (buffers *application-frame*)) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer pane) buffer) - (full-redisplay pane) - buffer)) - -(defmethod switch-to-buffer ((name string)) - (let ((buffer (find name (buffers *application-frame*) - :key #'name :test #'string=))) - (switch-to-buffer (or buffer - (make-buffer name))))) - -;;placeholder -(defmethod switch-to-buffer ((symbol (eql 'nil))) - (let ((default (second (buffers *application-frame*)))) - (when default - (switch-to-buffer default)))) - -;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, -;; ;;; 2005-10-31. -;; (defmethod (setf buffer) :around (buffer (pane extended-pane)) -;; (call-next-method) -;; (note-pane-syntax-changed pane (syntax buffer))) - -(define-command (com-switch-to-buffer :name t :command-table pane-table) () - "Prompt for a buffer name and switch to that buffer. -If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default." - (let* ((default (second (buffers *application-frame*))) - (buffer (if default - (accept 'buffer - :prompt "Switch to buffer" - :default default) - (accept 'buffer - :prompt "Switch to buffer")))) - (switch-to-buffer buffer))) - -(set-key 'com-switch-to-buffer - 'pane-table - '((#\x :control) (#\b))) - -(defgeneric kill-buffer (buffer)) - -(defmethod kill-buffer ((buffer climacs-buffer)) - (with-slots (buffers) *application-frame* - (when (and (needs-saving buffer) - (handler-case (accept 'boolean :prompt "Save buffer first?") - (error () (progn (beep) - (display-message "Invalid answer") - (return-from kill-buffer nil))))) - (com-save-buffer)) - (setf buffers (remove buffer buffers)) - ;; Always need one buffer. - (when (null buffers) - (make-buffer "*scratch*")) - (setf (buffer (current-window)) (car buffers)) - (full-redisplay (current-window)) - (buffer (current-window)))) - -(defmethod kill-buffer ((name string)) - (let ((buffer (find name (buffers *application-frame*) - :key #'name :test #'string=))) - (when buffer (kill-buffer buffer)))) - -(defmethod kill-buffer ((symbol (eql 'nil))) - (kill-buffer (buffer (current-window)))) - -(define-command (com-kill-buffer :name t :command-table pane-table) - ((buffer 'buffer - :prompt "Kill buffer" - :default (buffer (current-window)) - :default-type 'buffer)) - "Prompt for a buffer name and kill that buffer. -If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default." - (kill-buffer buffer)) - -(set-key `(com-kill-buffer ,*unsupplied-argument-marker*) - 'pane-table - '((#\x :control) (#\k))) - ;;; For the ESA help functions. (defmethod help-stream ((frame climacs) title) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/24 13:24:40 1.21 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/25 11:38:05 1.22 @@ -24,7 +24,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; File commands for the Climacs editor. +;;; File (and buffer) commands for the Climacs editor. (in-package :climacs-commands) @@ -113,99 +113,6 @@ (values default default-type)) (t (values string 'string))))) -(defun filepath-filename (pathname) - (if (null (pathname-type pathname)) - (pathname-name pathname) - (concatenate 'string (pathname-name pathname) - "." (pathname-type pathname)))) - -(defun syntax-class-name-for-filepath (filepath) - (or (climacs-syntax::syntax-description-class-name - (find (or (pathname-type filepath) - (pathname-name filepath)) - climacs-syntax::*syntaxes* - :test (lambda (x y) - (member x y :test #'string-equal)) - :key #'climacs-syntax::syntax-description-pathname-types)) - 'basic-syntax)) - -(defun evaluate-attributes (buffer options) - "Evaluate the attributes `options' and modify `buffer' as - appropriate. `Options' should be an alist mapping option names - to their values." - ;; First, check whether we need to change the syntax (via the SYNTAX - ;; option). MODE is an alias for SYNTAX for compatibility with - ;; Emacs. If there is more than one option with one of these names, - ;; only the first will be acted upon. - (let ((specified-syntax - (syntax-from-name - (second (find-if #'(lambda (name) - (or (string-equal name "SYNTAX") - (string-equal name "MODE"))) - options - :key #'first))))) - (when specified-syntax - (setf (syntax buffer) - (make-instance specified-syntax - :buffer buffer)))) - ;; Now we iterate through the options (discarding SYNTAX and MODE - ;; options). - (loop for (name value) in options - unless (or (string-equal name "SYNTAX") - (string-equal name "MODE")) - do (eval-option (syntax buffer) name value))) - -(defun split-attribute (string char) - (let (pairs) - (loop with start = 0 - for ch across string - for i from 0 - when (eql ch char) - do (push (string-trim '(#\Space #\Tab) (subseq string start i)) - pairs) - (setf start (1+ i)) - finally (unless (>= start i) - (push (string-trim '(#\Space #\Tab) (subseq string start)) - pairs))) - (nreverse pairs))) - -(defun split-attribute-line (line) - (mapcar (lambda (pair) (split-attribute pair #\:)) - (split-attribute line #\;))) - -(defun get-attribute-line (buffer) - (let ((scan (beginning-of-buffer (clone-mark (point buffer))))) - ;; skip the leading whitespace - (loop until (end-of-buffer-p scan) - until (not (whitespacep (syntax buffer) (object-after scan))) - do (forward-object scan)) - ;; stop looking if we're already 1,000 objects into the buffer - (unless (> (offset scan) 1000) - (let ((start-found - (loop with newlines = 0 - when (end-of-buffer-p scan) - do (return nil) - when (eql (object-after scan) #\Newline) - do (incf newlines) - when (> newlines 1) - do (return nil) - do (forward-object scan) - until (looking-at scan "-*-") - finally (return t)))) - (when start-found - (let ((line (buffer-substring buffer - (offset scan) - (offset (end-of-line (clone-mark scan)))))) - (when (>= (length line) 6) - (let ((end (search "-*-" line :from-end t :start2 3))) - (when end - (string-trim '(#\Space #\Tab) (subseq line 3 end))))))))))) - -(defun evaluate-attributes-line (buffer) - (evaluate-attributes - buffer - (split-attribute-line (get-attribute-line buffer)))) - (define-command (com-reparse-attribute-list :name t :command-table buffer-table) () "Reparse the current buffer's attribute list. An attribute list is a line of keyword-value pairs, each keyword separated @@ -220,82 +127,6 @@ ;; -*- Syntax: Lisp; Base: 10 -*- " (evaluate-attributes-line (buffer (current-window)))) -;; Adapted from cl-fad/PCL -(defun directory-pathname-p (pathspec) - "Returns NIL if PATHSPEC does not designate a directory." - (let ((name (pathname-name pathspec)) - (type (pathname-type pathspec))) - (and (or (null name) (eql name :unspecific)) - (or (null type) (eql type :unspecific))))) - -(defun find-file (filepath &optional readonlyp) - (cond ((null filepath) - (display-message "No file name given.") - (beep)) - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath) - (beep)) - (t - (flet ((usable-pathname (pathname) - (if (probe-file pathname) - (truename pathname) - pathname))) - (let ((existing-buffer (find filepath (buffers *application-frame*) - :key #'filepath - :test #'(lambda (fp1 fp2) - (and fp1 fp2 - (equal (usable-pathname fp1) - (usable-pathname fp2))))))) - (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) - (switch-to-buffer existing-buffer) - (progn - (when readonlyp - (unless (probe-file filepath) - (beep) - (display-message "No such file: ~A" filepath) - (return-from find-file nil))) - (let ((buffer (make-buffer)) - (pane (current-window))) - ;; Clear the pane's cache; otherwise residue from the - ;; previously displayed buffer may under certain - ;; circumstances be displayed. - (clear-cache pane) - (setf (syntax buffer) nil) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer (current-window)) buffer) - ;; Don't want to create the file if it doesn't exist. - (when (probe-file filepath) - (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0)) - (setf (file-write-time buffer) (file-write-date filepath)) - ;; A file! That means we may have a local options - ;; line to parse. - (evaluate-attributes-line buffer)) - ;; If the local options line didn't set a syntax, do - ;; it now. - (when (null (syntax buffer)) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer))) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil - (read-only-p buffer) readonlyp) - (beginning-of-buffer (point pane)) - (update-syntax buffer (syntax buffer)) - (clear-modify buffer) - buffer)))))))) - -(defun directory-of-buffer (buffer) - "Extract the directory part of the filepath to the file in BUFFER. - If BUFFER does not have a filepath, the path to the user's home - directory will be returned." - (make-pathname - :directory - (pathname-directory - (or (filepath buffer) - (user-homedir-pathname))))) - (define-command (com-find-file :name t :command-table buffer-table) ((filepath 'pathname :prompt "Find File" @@ -333,13 +164,6 @@ 'buffer-table '((#\x :control) (#\q :control))) -(defun set-visited-file-name (filename buffer) - (setf (filepath buffer) filename - (file-saved-p buffer) nil - (file-write-time buffer) nil - (name buffer) (filepath-filename filename) - (needs-saving buffer) t)) - (define-command (com-set-visited-file-name :name t :command-table buffer-table) ((filename 'pathname :prompt "New file name" :default (directory-of-buffer (buffer (current-window))) @@ -395,66 +219,6 @@ (display-message "No file ~A" filepath) (beep)))))) -(defun extract-version-number (pathname) - "Extracts the emacs-style version-number from a pathname." - (let* ((type (pathname-type pathname)) - (length (length type))) - (when (and (> length 2) (char= (char type (1- length)) #\~)) - (let ((tilde (position #\~ type :from-end t :end (- length 2)))) - (when tilde - (parse-integer type :start (1+ tilde) :junk-allowed t)))))) - -(defun version-number (pathname) - "Return the number of the highest versioned backup of PATHNAME -or 0 if there is no versioned backup. Looks for name.type~X~, -returns highest X." - (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname)) - (possibilities (directory wildpath))) - (loop for possibility in possibilities - for version = (extract-version-number possibility) - if (numberp version) - maximize version into max - finally (return max)))) - -(defun check-file-times (buffer filepath question answer) - "Return NIL if filepath newer than buffer and user doesn't want to overwrite" - (let ((f-w-d (file-write-date filepath)) - (f-w-t (file-write-time buffer))) - (if (and f-w-d f-w-t (> f-w-d f-w-t)) - (if (accept 'boolean - :prompt (format nil "File has changed on disk. ~a anyway?" - question)) - t - (progn (display-message "~a not ~a" filepath answer) - nil)) - t))) - -(defun save-buffer (buffer) - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory." filepath) - (beep)) - (t - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type))) - (setf (file-saved-p buffer) t)) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" filepath) - (setf (needs-saving buffer) nil))))) - (define-command (com-save-buffer :name t :command-table buffer-table) () "Write the contents of the buffer to a file. If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename." @@ -468,24 +232,6 @@ 'buffer-table '((#\x :control) (#\s :control))) -(defmethod frame-exit :around ((frame climacs) #-mcclim &key) - (loop for buffer in (buffers frame) - when (and (needs-saving buffer) - (filepath buffer) - (handler-case (accept 'boolean - :prompt (format nil "Save buffer: ~a ?" (name buffer))) - (error () (progn (beep) - (display-message "Invalid answer") - (return-from frame-exit nil))))) - do (save-buffer buffer)) - (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer))) - (buffers frame)) - (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") - (error () (progn (beep) - (display-message "Invalid answer") - (return-from frame-exit nil))))) - (call-next-method))) - (define-command (com-write-buffer :name t :command-table buffer-table) ((filepath 'pathname :prompt "Write Buffer to File" :default (directory-of-buffer (buffer (current-window))) @@ -509,3 +255,76 @@ 'buffer-table '((#\x :control) (#\w :control))) +(defun load-file (file-name) + (cond ((directory-pathname-p file-name) + (display-message "~A is a directory name." file-name) + (beep)) + (t + (cond ((probe-file file-name) + (load file-name)) + (t + (display-message "No such file: ~A" file-name) + (beep)))))) + +(define-command (com-load-file :name t :command-table base-table) () + "Prompt for a filename and CL:LOAD that file. +Signals and error if the file does not exist." + (let ((filepath (accept 'pathname :prompt "Load File"))) + (load-file filepath))) + +(set-key 'com-load-file + 'base-table + '((#\c :control) (#\l :control))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Buffer commands + +(define-command (com-switch-to-buffer :name t :command-table pane-table) () + "Prompt for a buffer name and switch to that buffer. +If the a buffer with that name does not exist, create it. Uses the name of the next buffer (if any) as a default." + (let* ((default (second (buffers *application-frame*))) + (buffer (if default + (accept 'buffer + :prompt "Switch to buffer" + :default default) + (accept 'buffer + :prompt "Switch to buffer")))) + (switch-to-buffer buffer))) + +(set-key 'com-switch-to-buffer + 'pane-table + '((#\x :control) (#\b))) + +(define-command (com-kill-buffer :name t :command-table pane-table) + ((buffer 'buffer + :prompt "Kill buffer" + :default (buffer (current-window)) + :default-type 'buffer)) + "Prompt for a buffer name and kill that buffer. +If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default." + (kill-buffer buffer)) + +(set-key `(com-kill-buffer ,*unsupplied-argument-marker*) + 'pane-table + '((#\x :control) (#\k))) + +(define-command (com-toggle-read-only :name t :command-table base-table) + ((buffer 'buffer :default (current-buffer))) + (setf (read-only-p buffer) (not (read-only-p buffer)))) + +(define-presentation-to-command-translator toggle-read-only + (read-only com-toggle-read-only base-table + :gesture :menu) + (object) + (list object)) + +(define-command (com-toggle-modified :name t :command-table base-table) + ((buffer 'buffer :default (current-buffer))) + (setf (needs-saving buffer) (not (needs-saving buffer)))) + +(define-presentation-to-command-translator toggle-modified + (modified com-toggle-modified base-table + :gesture :menu) + (object) + (list object)) \ No newline at end of file --- /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 1.1 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/07/25 11:38:05 1.2 @@ -17,6 +17,37 @@ ;;; ;;; Misc stuff +(defun display-string (string) + (with-output-to-string (result) + (loop for char across string + do (cond ((graphic-char-p char) (princ char result)) + ((char= char #\Space) (princ char result)) + (t (prin1 char result)))))) + +(defun object-equal (x y) + "Case insensitive equality that doesn't require characters" + (if (characterp x) + (and (characterp y) (char-equal x y)) + (eql x y))) + +(defun object= (x y) + "Case sensitive equality that doesn't require characters" + (if (characterp x) + (and (characterp y) (char= x y)) + (eql x y))) + +(defun no-upper-p (string) + "Does STRING contain no uppercase characters" + (notany #'upper-case-p string)) + +(defun case-relevant-test (string) + "Returns a test function based on the search-string STRING. +If STRING contains no uppercase characters the test is case-insensitive, +otherwise it is case-sensitive." + (if (no-upper-p string) + #'object-equal + #'object=)) + (defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) @@ -278,3 +309,391 @@ (when (and (not (beginning-of-buffer-p mark)) (constituentp (object-before mark))) (insert-object mark #\Space)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Syntax handling + +(defgeneric set-syntax (buffer syntax)) + +(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax)) + (setf (syntax buffer) syntax)) + +;;FIXME - what should this specialise on? +(defmethod set-syntax ((buffer climacs-buffer) syntax) + (set-syntax buffer (make-instance syntax :buffer buffer))) + +(defmethod set-syntax ((buffer climacs-buffer) (syntax string)) + (let ((syntax-class (syntax-from-name syntax))) + (cond (syntax-class + (set-syntax buffer (make-instance syntax-class + :buffer buffer))) + (t + (beep) + (display-message "No such syntax: ~A." syntax))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Buffer handling + +(defun make-buffer (&optional name) + (let ((buffer (make-instance 'climacs-buffer))) + (when name (setf (name buffer) name)) + (push buffer (buffers *application-frame*)) + buffer)) + +(defgeneric erase-buffer (buffer)) + +(defmethod erase-buffer ((buffer string)) + (let ((b (find buffer (buffers *application-frame*) + :key #'name :test #'string=))) + (when b (erase-buffer b)))) + +(defmethod erase-buffer ((buffer climacs-buffer)) + (let* ((point (point buffer)) + (mark (clone-mark point))) + (beginning-of-buffer mark) + (end-of-buffer point) + (delete-region mark point))) + +(define-presentation-method present (object (type buffer) + stream + (view textual-view) + &key acceptably for-context-type) + (declare (ignore acceptably for-context-type)) + (princ (name object) stream)) + +(define-presentation-method accept + ((type buffer) stream (view textual-view) &key (default nil defaultp) + (default-type type)) + (multiple-value-bind (object success string) + (complete-input stream + (lambda (so-far action) + (complete-from-possibilities + so-far (buffers *application-frame*) '() :action action + :name-key #'name + :value-key #'identity)) + :partial-completers '(#\Space) + :allow-any-input t) + (cond (success + (values object type)) + ((and (zerop (length string)) defaultp) + (values default default-type)) + (t (values string 'string))))) + +(defgeneric switch-to-buffer (buffer)) + +(defmethod switch-to-buffer ((buffer climacs-buffer)) + (let* ((buffers (buffers *application-frame*)) + (position (position buffer buffers)) + (pane (current-window))) + (when position + (setf buffers (delete buffer buffers))) + (push buffer (buffers *application-frame*)) + (setf (offset (point (buffer pane))) (offset (point pane))) + (setf (buffer pane) buffer) + (full-redisplay pane) + buffer)) + +(defmethod switch-to-buffer ((name string)) + (let ((buffer (find name (buffers *application-frame*) + :key #'name :test #'string=))) + (switch-to-buffer (or buffer + (make-buffer name))))) + +;;placeholder +(defmethod switch-to-buffer ((symbol (eql 'nil))) + (let ((default (second (buffers *application-frame*)))) + (when default + (switch-to-buffer default)))) + +;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, +;; ;;; 2005-10-31. +;; (defmethod (setf buffer) :around (buffer (pane extended-pane)) +;; (call-next-method) +;; (note-pane-syntax-changed pane (syntax buffer))) + +(defgeneric kill-buffer (buffer)) + +(defmethod kill-buffer ((buffer climacs-buffer)) + (with-slots (buffers) *application-frame* + (when (and (needs-saving buffer) + (handler-case (accept 'boolean :prompt "Save buffer first?") + (error () (progn (beep) + (display-message "Invalid answer") + (return-from kill-buffer nil))))) + (save-buffer buffer)) + (setf buffers (remove buffer buffers)) + ;; Always need one buffer. + (when (null buffers) + (make-buffer "*scratch*")) + (setf (buffer (current-window)) (car buffers)) + (full-redisplay (current-window)) + (buffer (current-window)))) + +(defmethod kill-buffer ((name string)) + (let ((buffer (find name (buffers *application-frame*) + :key #'name :test #'string=))) + (when buffer (kill-buffer buffer)))) + +(defmethod kill-buffer ((symbol (eql 'nil))) + (kill-buffer (buffer (current-window)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; File handling + +(defun filepath-filename (pathname) + (if (null (pathname-type pathname)) + (pathname-name pathname) + (concatenate 'string (pathname-name pathname) + "." (pathname-type pathname)))) + +(defun syntax-class-name-for-filepath (filepath) + (or (climacs-syntax::syntax-description-class-name + (find (or (pathname-type filepath) + (pathname-name filepath)) + climacs-syntax::*syntaxes* + :test (lambda (x y) + (member x y :test #'string-equal)) + :key #'climacs-syntax::syntax-description-pathname-types)) + 'basic-syntax)) + +(defun evaluate-attributes (buffer options) + "Evaluate the attributes `options' and modify `buffer' as + appropriate. `Options' should be an alist mapping option names + to their values." + ;; First, check whether we need to change the syntax (via the SYNTAX + ;; option). MODE is an alias for SYNTAX for compatibility with + ;; Emacs. If there is more than one option with one of these names, + ;; only the first will be acted upon. + (let ((specified-syntax + (syntax-from-name + (second (find-if #'(lambda (name) + (or (string-equal name "SYNTAX") + (string-equal name "MODE"))) + options + :key #'first))))) + (when specified-syntax + (setf (syntax buffer) + (make-instance specified-syntax + :buffer buffer)))) + ;; Now we iterate through the options (discarding SYNTAX and MODE + ;; options). + (loop for (name value) in options + unless (or (string-equal name "SYNTAX") + (string-equal name "MODE")) + do (eval-option (syntax buffer) name value))) + +(defun split-attribute (string char) + (let (pairs) + (loop with start = 0 + for ch across string + for i from 0 + when (eql ch char) + do (push (string-trim '(#\Space #\Tab) (subseq string start i)) + pairs) + (setf start (1+ i)) + finally (unless (>= start i) + (push (string-trim '(#\Space #\Tab) (subseq string start)) + pairs))) + (nreverse pairs))) + +(defun split-attribute-line (line) + (mapcar (lambda (pair) (split-attribute pair #\:)) + (split-attribute line #\;))) + +(defun get-attribute-line (buffer) + (let ((scan (beginning-of-buffer (clone-mark (point buffer))))) + ;; skip the leading whitespace + (loop until (end-of-buffer-p scan) + until (not (whitespacep (syntax buffer) (object-after scan))) + do (forward-object scan)) + ;; stop looking if we're already 1,000 objects into the buffer + (unless (> (offset scan) 1000) + (let ((start-found + (loop with newlines = 0 + when (end-of-buffer-p scan) + do (return nil) + when (eql (object-after scan) #\Newline) + do (incf newlines) + when (> newlines 1) + do (return nil) + do (forward-object scan) + until (looking-at scan "-*-") + finally (return t)))) + (when start-found + (let ((line (buffer-substring buffer + (offset scan) + (offset (end-of-line (clone-mark scan)))))) + (when (>= (length line) 6) + (let ((end (search "-*-" line :from-end t :start2 3))) + (when end + (string-trim '(#\Space #\Tab) (subseq line 3 end))))))))))) + +(defun evaluate-attributes-line (buffer) + (evaluate-attributes + buffer + (split-attribute-line (get-attribute-line buffer)))) + +;; Adapted from cl-fad/PCL +(defun directory-pathname-p (pathspec) + "Returns NIL if PATHSPEC does not designate a directory." + (let ((name (pathname-name pathspec)) + (type (pathname-type pathspec))) + (and (or (null name) (eql name :unspecific)) + (or (null type) (eql type :unspecific))))) + +(defun find-file (filepath &optional readonlyp) + (cond ((null filepath) + (display-message "No file name given.") + (beep)) + ((directory-pathname-p filepath) + (display-message "~A is a directory name." filepath) + (beep)) + (t + (flet ((usable-pathname (pathname) + (if (probe-file pathname) + (truename pathname) + pathname))) + (let ((existing-buffer (find filepath (buffers *application-frame*) + :key #'filepath + :test #'(lambda (fp1 fp2) + (and fp1 fp2 + (equal (usable-pathname fp1) + (usable-pathname fp2))))))) + (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) + (switch-to-buffer existing-buffer) + (progn + (when readonlyp + (unless (probe-file filepath) + (beep) + (display-message "No such file: ~A" filepath) + (return-from find-file nil))) + (let ((buffer (make-buffer)) + (pane (current-window))) + ;; Clear the pane's cache; otherwise residue from the + ;; previously displayed buffer may under certain + ;; circumstances be displayed. + (clear-cache pane) + (setf (syntax buffer) nil) + (setf (offset (point (buffer pane))) (offset (point pane))) + (setf (buffer (current-window)) buffer) + ;; Don't want to create the file if it doesn't exist. + (when (probe-file filepath) + (with-open-file (stream filepath :direction :input) + (input-from-stream stream buffer 0)) + (setf (file-write-time buffer) (file-write-date filepath)) + ;; A file! That means we may have a local options + ;; line to parse. + (evaluate-attributes-line buffer)) + ;; If the local options line didn't set a syntax, do + ;; it now. + (when (null (syntax buffer)) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer))) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil + (read-only-p buffer) readonlyp) + (beginning-of-buffer (point pane)) + (update-syntax buffer (syntax buffer)) + (clear-modify buffer) + buffer)))))))) + +(defun directory-of-buffer (buffer) + "Extract the directory part of the filepath to the file in BUFFER. + If BUFFER does not have a filepath, the path to the user's home + directory will be returned." + (make-pathname + :directory + (pathname-directory + (or (filepath buffer) + (user-homedir-pathname))))) + +(defun set-visited-file-name (filename buffer) + (setf (filepath buffer) filename + (file-saved-p buffer) nil + (file-write-time buffer) nil + (name buffer) (filepath-filename filename) + (needs-saving buffer) t)) + +(defun extract-version-number (pathname) + "Extracts the emacs-style version-number from a pathname." + (let* ((type (pathname-type pathname)) + (length (length type))) + (when (and (> length 2) (char= (char type (1- length)) #\~)) + (let ((tilde (position #\~ type :from-end t :end (- length 2)))) + (when tilde + (parse-integer type :start (1+ tilde) :junk-allowed t)))))) + +(defun version-number (pathname) + "Return the number of the highest versioned backup of PATHNAME +or 0 if there is no versioned backup. Looks for name.type~X~, +returns highest X." + (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname)) + (possibilities (directory wildpath))) + (loop for possibility in possibilities + for version = (extract-version-number possibility) + if (numberp version) + maximize version into max + finally (return max)))) + +(defun check-file-times (buffer filepath question answer) + "Return NIL if filepath newer than buffer and user doesn't want +to overwrite." + (let ((f-w-d (file-write-date filepath)) + (f-w-t (file-write-time buffer))) + (if (and f-w-d f-w-t (> f-w-d f-w-t)) + (if (accept 'boolean + :prompt (format nil "File has changed on disk. ~a anyway?" + question)) + t + (progn (display-message "~a not ~a" filepath answer) + nil)) + t))) + +(defun save-buffer (buffer) + (let ((filepath (or (filepath buffer) + (accept 'pathname :prompt "Save Buffer to File")))) + (cond + ((directory-pathname-p filepath) + (display-message "~A is a directory." filepath) + (beep)) + (t + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) [33 lines skipped] --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/24 13:24:40 1.48 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/25 11:38:05 1.49 @@ -97,14 +97,14 @@ (:file "core" :depends-on ("gui")) (:file "climacs" :depends-on ("gui" "core")) ;; (:file "buffer-commands" :depends-on ("gui")) - (:file "developer-commands" :depends-on ("gui" "lisp-syntax")) - (:file "motion-commands" :depends-on ("gui")) - (:file "editing-commands" :depends-on ("gui")) - (:file "file-commands" :depends-on ("gui")) - (:file "misc-commands" :depends-on ("gui")) - (:file "search-commands" :depends-on ("gui")) - (:file "window-commands" :depends-on ("gui")) - (:file "unicode-commands" :depends-on ("gui")) + (:file "developer-commands" :depends-on ("gui" "lisp-syntax" "core")) + (:file "motion-commands" :depends-on ("gui" "core")) + (:file "editing-commands" :depends-on ("gui" "core")) + (:file "file-commands" :depends-on ("gui" "core")) + (:file "misc-commands" :depends-on ("gui" "core")) + (:file "search-commands" :depends-on ("gui" "core")) + (:file "window-commands" :depends-on ("gui" "core")) + (:file "unicode-commands" :depends-on ("gui" "core")) (:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane" )) (:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui"))))

1 0

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

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16618 Modified Files: lisp-syntax.lisp Log Message: Ironed out some more bugs in the implementation of intelligent completion for keyword parameters - &rest arguments are handled and indirect arglists fetched now. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 08:20:27 1.98 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 20:52:23 1.99 @@ -3840,11 +3840,13 @@ sense to use at the position `arg-indices' relative to the operator that has the argument list `arglist'." (let* ((key-position (position '&key arglist)) + (rest-position (position '&rest arglist)) (cleaned-arglist (remove-if #'arglist-keyword-p arglist)) (index (first arg-indices)) - (difference (- (length arglist) - (length cleaned-arglist)))) + (difference (+ (- (length arglist) + (length cleaned-arglist)) + (if rest-position 1 0)))) (cond ((and (null key-position) (rest arg-indices) (> (length cleaned-arglist) @@ -3857,11 +3859,12 @@ (>= (+ index difference) key-position) - (not (evenp (- index key-position difference)))) + (evenp (- index (- key-position + (1- difference))))) (mapcar #'unlisted (subseq cleaned-arglist - (- key-position - difference - -1))))))) + (+ (- key-position + difference) + (if rest-position 2 1)))))))) (defun completions-from-keywords (syntax token) "Assume that `token' is a (partial) keyword argument @@ -3871,10 +3874,11 @@ doesn't take keyword arguments)." (with-code-insight (start-offset token) syntax (:preceding-operand-indices poi - :operator operator) + :operator operator + :operands operands) (when (valid-operator-p operator) (let* ((relevant-keywords - (relevant-keywords (arglist-for-form operator) + (relevant-keywords (arglist-for-form operator operands) poi)) (completions (simple-completions (get-usable-image syntax)

1 0

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

24 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv26762/Doc Modified Files: climacs-user.texi Log Message: Climacs entry point in in the CLIMACS package, add mention of :new-process argument. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:55:45 1.12 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/24 17:58:32 1.13 @@ -207,7 +207,13 @@ @emph{expression} at the prompt of a @cl{} @emph{listener} such as: @lisp -CL-USER> (climacs-gui:climacs) +CL-USER> (climacs:climacs) +@end lisp + +@climacs{} also has an option to start in a new thread: + +@lisp +CL-USER> (climacs:climacs :new-process t) @end lisp You exit from @climacs{} by typing @kbd{C-x C-c} (@command{Quit}).

1 0

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

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13591 Modified Files: window-commands.lisp search-commands.lisp packages.lisp misc-commands.lisp kill-ring.lisp gui.lisp base.lisp Log Message: * Moved some functions from window-commands.lisp to gui.lisp (and the CLIMACs-GUI package) and export them. * The kill ring is no longer a global, special symbol, thus fixing a bunch of problems regarding sharing of kill rings between instances of Climacs (and remembering the kill ring across invocations). * Various yank-commands no longer signal an error when the kill ring is empty. This is done by handling the flexichain:at-end-error condition, which is suboptimal - user code should not need to be aware of the implementation of the kill ring. Will be fixed at some point. CVS problems made it too hard to divide this up into several patches, sorry. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 13:24:40 1.9 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 16:33:16 1.10 @@ -32,123 +32,6 @@ ;;; ;;; Commands for splitting windows -(defun replace-constellation (constellation additional-constellation vertical-p) - (let* ((parent (sheet-parent constellation)) - (children (sheet-children parent)) - (first (first children)) - (second (second children)) - (third (third children)) - (first-split-p (= (length (sheet-children parent)) 2)) - (parent-region (sheet-region parent)) - (parent-height (rectangle-height parent-region)) - (parent-width (rectangle-width parent-region)) - (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing. - (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget))) - (assert (member constellation children)) - - (when first-split-p (setf (sheet-region filler) (sheet-region parent)) - (sheet-adopt-child parent filler)) - - (sheet-disown-child parent constellation) - - (if vertical-p - (resize-sheet constellation parent-width (/ parent-height 2)) - (resize-sheet constellation (/ parent-width 2) parent-height)) - - (let ((new (if vertical-p - (vertically () - constellation adjust additional-constellation) - (horizontally () - constellation adjust additional-constellation)))) - (sheet-adopt-child parent new) - - (when first-split-p (sheet-disown-child parent filler)) - (reorder-sheets parent - (if (eq constellation first) - (if third - (list new second third) - (list new second)) - (if third - (list first second new) - (list first new))))))) - -(defun find-parent (sheet) - (loop for parent = (sheet-parent sheet) - then (sheet-parent parent) - until (typep parent 'vrack-pane) - finally (return parent))) - -(defclass typeout-pane (application-pane esa-pane-mixin) ()) - -(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)) - (label - (make-pane 'label-pane :label label)) - (vbox - (vertically () - (scrolling (:scroll-bar :vertical) typeout-pane) label))) - (values vbox typeout-pane))) - -(defun typeout-window (&optional (label "Typeout") (pane (current-window))) - (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)))) - -(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*)) - "make a vbox containing a scroller pane as its first child and an -info pane as its second child. The scroller pane contains a viewport -which contains an extended pane. Return the vbox and the extended pane -as two values. -If with-scrollbars nil, omit the scroller." - (let* ((extended-pane - (make-pane 'extended-pane - :width 900 :height 400 - :name 'window - :end-of-line-action :scroll - :incremental-redisplay t - :background *bg-color* - :foreground *fg-color* - :display-function 'display-window - :command-table 'global-climacs-table)) - (vbox - (vertically () - (if with-scrollbars - (scrolling () - extended-pane) - extended-pane) - (make-pane 'climacs-info-pane - :background *info-bg-color* - :foreground *info-fg-color* - :master-pane extended-pane - :width 900)))) - (values vbox extended-pane))) - -(defun split-window (&optional (vertically-p nil) (pane (current-window))) - (with-look-and-feel-realization - ((frame-manager *application-frame*) *application-frame*) - (multiple-value-bind (vbox new-pane) (make-pane-constellation) - (let* ((current-window pane) - (constellation-root (find-parent current-window))) - (setf (offset (point (buffer current-window))) (offset (point current-window)) - (buffer new-pane) (buffer current-window) - (auto-fill-mode new-pane) (auto-fill-mode current-window) - (auto-fill-column new-pane) (auto-fill-column current-window)) - (push new-pane (windows *application-frame*)) - (setf *standard-output* new-pane) - (replace-constellation constellation-root vbox vertically-p) - (full-redisplay current-window) - (full-redisplay new-pane) - new-pane)))) - (define-command (com-split-window-vertically :name t :command-table window-table) () (split-window t)) @@ -163,20 +46,6 @@ 'window-table '((#\x :control) (#\3))) -(defun other-window (&optional pane) - (if (and pane (find pane (windows *application-frame*))) - (setf (windows *application-frame*) - (append (list pane) - (remove pane (windows *application-frame*)))) - (setf (windows *application-frame*) - (append (cdr (windows *application-frame*)) - (list (car (windows *application-frame*)))))) - ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge. - (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*)))) - (> (length (windows *application-frame*)) 1)) - (other-window) - (setf *standard-output* (car (windows *application-frame*))))) - (define-command (com-other-window :name t :command-table window-table) () (other-window)) @@ -282,33 +151,6 @@ 'window-table '((#\V :control :meta :shift))) -(defun delete-window (&optional (window (current-window))) - (unless (null (cdr (windows *application-frame*))) - (let* ((constellation (find-parent window)) - (box (sheet-parent constellation)) - (box-children (sheet-children box)) - (other (if (eq constellation (first box-children)) - (third box-children) - (first box-children))) - (parent (sheet-parent box)) - (children (sheet-children parent)) - (first (first children)) - (second (second children)) - (third (third children))) - (setf (windows *application-frame*) - (remove window (windows *application-frame*))) - (setf *standard-output* (car (windows *application-frame*))) - (sheet-disown-child box other) - (sheet-adopt-child parent other) - (sheet-disown-child parent box) - (reorder-sheets parent (if (eq box first) - (if third - (list other second third) - (list other second)) - (if third - (list first second other) - (list first other))))))) - (define-command (com-delete-window :name t :command-table window-table) () (delete-window)) --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 13:24:40 1.9 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 16:33:16 1.10 @@ -209,7 +209,9 @@ (define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (states (isearch-states pane)) - (yank (kill-ring-yank *kill-ring*)) + (yank (handler-case (kill-ring-yank *kill-ring*) + (flexichain:at-end-error () + ""))) (string (concatenate 'string (search-string (first states)) yank)) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 13:24:40 1.106 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 16:33:16 1.107 @@ -70,7 +70,8 @@ #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push - #:kill-ring-reverse-concatenating-push) + #:kill-ring-reverse-concatenating-push + #:*kill-ring*) (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base @@ -99,8 +100,7 @@ #:downcase-buffer-region #:downcase-region #:upcase-buffer-region #:upcase-region #:capitalize-buffer-region #:capitalize-region - #:tabify-region #:untabify-region - #:*kill-ring*) + #:tabify-region #:untabify-region) (:documentation "Basic functionality built on top of the buffer protocol. Here is where we define slightly higher level functions, that can be directly implemented in terms of the @@ -318,6 +318,8 @@ #:extended-pane #:climacs-info-pane + #:typeout-pane + #:kill-ring ;; GUI functions follow. #:current-window @@ -333,6 +335,10 @@ #:erase-buffer #:buffer-pane-p #:display-window + #:split-window + #:typeout-window + #:delete-window + #:other-window ;; Some configuration variables #:*bg-color* --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 13:24:40 1.17 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 16:33:16 1.18 @@ -476,7 +476,9 @@ ;; Copies an element from a kill-ring to a buffer at the given offset (define-command (com-yank :name t :command-table editing-table) () "Insert the objects most recently added to the kill ring at point." - (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) + (handler-case (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)) + (flexichain:at-end-error () + (display-message "Kill ring is empty")))) (set-key 'com-yank 'editing-table @@ -510,15 +512,17 @@ Must be given immediately following a Yank or Rotate Yank command. The replacement objects are those before the previously yanked objects in the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (last-yank (kill-ring-yank *kill-ring*))) - (if (eq (previous-command pane) - 'com-rotate-yank) - (progn - (delete-range point (* -1 (length last-yank))) - (rotate-yank-position *kill-ring*))) - (insert-sequence point (kill-ring-yank *kill-ring*)))) + (handler-case (let* ((pane (current-window)) + (point (point pane)) + (last-yank (kill-ring-yank *kill-ring*))) + (if (eq (previous-command pane) + 'com-rotate-yank) + (progn + (delete-range point (* -1 (length last-yank))) + (rotate-yank-position *kill-ring*))) + (insert-sequence point (kill-ring-yank *kill-ring*))) + (flexichain:at-end-error () + (display-message "Kill ring is empty")))) (set-key 'com-rotate-yank 'editing-table --- /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/03/03 19:38:57 1.9 +++ /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/24 16:33:16 1.10 @@ -150,4 +150,8 @@ (defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil)) (if reset (reset-yank-position kr)) - (element> (kill-ring-cursor kr))) \ No newline at end of file + (element> (kill-ring-cursor kr))) + +(defparameter *kill-ring* nil + "This special variable is bound to the kill ring of the running + Climacs, whenever a command is executed.") \ No newline at end of file --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 13:24:40 1.223 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 16:33:16 1.224 @@ -37,6 +37,9 @@ (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (overwrite-mode :initform nil :accessor overwrite-mode))) +(defclass typeout-pane (application-pane esa-pane-mixin) + ()) + (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -124,10 +127,10 @@ (defvar *mini-bg-color* +white+) (defvar *mini-fg-color* +black+) - (define-application-frame climacs (standard-application-frame esa-frame-mixin) - ((buffers :initform '() :accessor buffers)) + ((buffers :initform '() :accessor buffers) + (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)) (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table @@ -184,7 +187,9 @@ (vertically (:scroll-bars nil) climacs-window minibuffer))) - (:top-level (esa-top-level :prompt "M-x "))) + (:top-level ((lambda (frame) + (let ((*kill-ring* (kill-ring frame))) + (esa-top-level frame :prompt "M-x ")))))) (defmethod frame-standard-input ((frame climacs)) (get-frame-pane frame 'minibuffer)) @@ -380,8 +385,150 @@ 'self-insert-table '((#\Newline))) -;;;;;;;;;;;;;;;;;;; -;;; Pane commands +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Pane/buffer functions + +(defun replace-constellation (constellation additional-constellation vertical-p) + (let* ((parent (sheet-parent constellation)) + (children (sheet-children parent)) + (first (first children)) + (second (second children)) + (third (third children)) + (first-split-p (= (length (sheet-children parent)) 2)) + (parent-region (sheet-region parent)) + (parent-height (rectangle-height parent-region)) + (parent-width (rectangle-width parent-region)) + (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing. + (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget))) + (assert (member constellation children)) + + (when first-split-p (setf (sheet-region filler) (sheet-region parent)) + (sheet-adopt-child parent filler)) + + (sheet-disown-child parent constellation) + + (if vertical-p + (resize-sheet constellation parent-width (/ parent-height 2)) + (resize-sheet constellation (/ parent-width 2) parent-height)) + + (let ((new (if vertical-p + (vertically () + constellation adjust additional-constellation) + (horizontally () + constellation adjust additional-constellation)))) + (sheet-adopt-child parent new) + + (when first-split-p (sheet-disown-child parent filler)) + (reorder-sheets parent + (if (eq constellation first) + (if third + (list new second third) + (list new second)) + (if third + (list first second new) + (list first new))))))) +(defun find-parent (sheet) + (loop for parent = (sheet-parent sheet) + then (sheet-parent parent) + until (typep parent 'vrack-pane) + finally (return parent))) + +(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*)) + "make a vbox containing a scroller pane as its first child and an +info pane as its second child. The scroller pane contains a viewport +which contains an extended pane. Return the vbox and the extended pane +as two values. +If with-scrollbars nil, omit the scroller." + (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'window + :end-of-line-action :scroll + :incremental-redisplay t + :background *bg-color* + :foreground *fg-color* + :display-function 'display-window + :command-table 'global-climacs-table)) + (vbox + (vertically () + (if with-scrollbars + (scrolling () + extended-pane) + extended-pane) + (make-pane 'climacs-info-pane + :background *info-bg-color* + :foreground *info-fg-color* + :master-pane extended-pane + :width 900)))) + (values vbox extended-pane))) + +(defun split-window (&optional (vertically-p nil) (pane (current-window))) + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window pane) + (constellation-root (find-parent current-window))) + (setf (offset (point (buffer current-window))) (offset (point current-window)) + (buffer new-pane) (buffer current-window) + (auto-fill-mode new-pane) (auto-fill-mode current-window) + (auto-fill-column new-pane) (auto-fill-column current-window)) + (push new-pane (windows *application-frame*)) + (setf *standard-output* new-pane) + (replace-constellation constellation-root vbox vertically-p) + (full-redisplay current-window) + (full-redisplay new-pane) + new-pane)))) + +(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)) + (label + (make-pane 'label-pane :label label)) + (vbox + (vertically () + (scrolling (:scroll-bar :vertical) typeout-pane) label))) + (values vbox typeout-pane))) + +(defun typeout-window (&optional (label "Typeout") (pane (current-window))) + (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)))) + +(defun delete-window (&optional (window (current-window))) + (unless (null (cdr (windows *application-frame*))) + (let* ((constellation (find-parent window)) + (box (sheet-parent constellation)) + (box-children (sheet-children box)) + (other (if (eq constellation (first box-children)) + (third box-children) + (first box-children))) + (parent (sheet-parent box)) + (children (sheet-children parent)) + (first (first children)) + (second (second children)) + (third (third children))) + (setf (windows *application-frame*) + (remove window (windows *application-frame*))) + (setf *standard-output* (car (windows *application-frame*))) + (sheet-disown-child box other) + (sheet-adopt-child parent other) + (sheet-disown-child parent box) + (reorder-sheets parent (if (eq box first) + (if third + (list other second third) + (list other second)) + (if third + (list first second other) + (list first other))))))) (defun make-buffer (&optional name) (let ((buffer (make-instance 'climacs-buffer))) @@ -389,6 +536,20 @@ (push buffer (buffers *application-frame*)) buffer)) +(defun other-window (&optional pane) + (if (and pane (find pane (windows *application-frame*))) + (setf (windows *application-frame*) + (append (list pane) + (remove pane (windows *application-frame*)))) + (setf (windows *application-frame*) + (append (cdr (windows *application-frame*)) + (list (car (windows *application-frame*)))))) + ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge. + (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*)))) + (> (length (windows *application-frame*)) 1)) + (other-window) + (setf *standard-output* (car (windows *application-frame*))))) + (defgeneric erase-buffer (buffer)) (defmethod erase-buffer ((buffer string)) --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 13:24:40 1.56 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 16:33:16 1.57 @@ -663,9 +663,3 @@ (when (> offset1 offset2) (rotatef offset1 offset2)) (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Kill ring - -(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))

1 0

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

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28595 Added Files: core.lisp Log Message: Added core.lisp - needed for my previous patch. Oops. --- /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 NONE +++ /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson(a)fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) (in-package :climacs-core) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Misc stuff (defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) (when (auto-fill-mode pane) (let* ((fill-column (auto-fill-column pane)) (point (point pane)) (offset (offset point)) (tab-width (tab-space-count (stream-default-view pane))) (syntax (syntax buffer))) (when (>= (buffer-display-column buffer offset tab-width) (1- fill-column)) (fill-line point (lambda (mark) (syntax-line-indentation mark tab-width syntax)) fill-column tab-width (syntax buffer))))))) (defun insert-character (char) (let* ((window (current-window)) (point (point window))) (unless (constituentp char) (possibly-expand-abbrev point)) (when (whitespacep (syntax (buffer window)) char) (possibly-fill-line)) (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) (progn (delete-range point) (insert-object point char)) (insert-object point char)))) (defun back-to-indentation (mark syntax) (beginning-of-line mark) (loop until (end-of-line-p mark) while (whitespacep syntax (object-after mark)) do (forward-object mark))) (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil)) (let ((mark2 (clone-mark mark))) (loop until (beginning-of-line-p mark) while (whitespacep syntax (object-before mark)) do (backward-object mark)) (unless backward-only-p (loop until (end-of-line-p mark2) while (whitespacep syntax (object-after mark2)) do (forward-object mark2))) (delete-region mark mark2))) (defun goto-position (mark pos) (setf (offset mark) pos)) (defun goto-line (mark line-number) (loop with m = (clone-mark (low-mark (buffer mark)) :right) initially (beginning-of-buffer m) do (end-of-line m) until (end-of-buffer-p m) repeat (1- line-number) do (incf (offset m)) (end-of-line m) finally (beginning-of-line m) (setf (offset mark) (offset m)))) (defun indent-current-line (pane point) (let* ((buffer (buffer pane)) (view (stream-default-view pane)) (tab-space-count (tab-space-count view)) (indentation (syntax-line-indentation point tab-space-count (syntax buffer)))) (indent-line point indentation (and (indent-tabs-mode buffer) tab-space-count)))) (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\))) (cond ((> count 0) (loop while (and (not (end-of-buffer-p mark)) (whitespacep syntax (object-after mark))) do (forward-object mark))) ((< count 0) (setf count (- count)) (loop repeat count do (backward-expression mark syntax)))) (unless (or (beginning-of-buffer-p mark) (whitespacep syntax (object-before mark))) (insert-object mark #\Space)) (insert-object mark open) (let ((here (clone-mark mark))) (loop repeat count do (forward-expression here syntax)) (insert-object here close) (unless (or (end-of-buffer-p here) (whitespacep syntax (object-after here))) (insert-object here #\Space)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case (defun downcase-word (mark &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (downcase-region offset mark))))) (defun upcase-word (mark syntax &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (upcase-region offset mark)))) (defun capitalize-word (mark &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (capitalize-region offset mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Indentation (defun indent-region (pane mark1 mark2) "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `pane'." (let* ((buffer (buffer pane)) (view (clim:stream-default-view pane)) (tab-space-count (tab-space-count view)) (tab-width (and (indent-tabs-mode buffer) tab-space-count)) (syntax (syntax buffer))) (do-buffer-region-lines (line mark1 mark2) (let ((indentation (syntax-line-indentation line tab-space-count syntax))) (indent-line line indentation tab-width)) ;; We need to update the syntax every time we perform an ;; indentation, so that subsequent indentations will be ;; correctly indented (this matters in list forms). FIXME: This ;; should probably happen automatically. (update-syntax buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Auto fill (defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax &optional (compress-whitespaces t)) "Breaks the contents of line pointed to by MARK up to MARK into multiple lines such that none of them is longer than FILL-COLUMN. If COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the decision is made to break the line at a point. For now, the compression means just the deletion of trailing whitespaces." (let ((begin-mark (clone-mark mark))) (beginning-of-line begin-mark) (loop with column = 0 with line-beginning-offset = (offset begin-mark) with walking-mark = (clone-mark begin-mark) while (mark< walking-mark mark) as object = (object-after walking-mark) do (case object (#\Space (setf (offset begin-mark) (offset walking-mark)) (incf column)) (#\Tab (setf (offset begin-mark) (offset walking-mark)) (incf column (- tab-width (mod column tab-width)))) (t (incf column))) (when (and (>= column fill-column) (/= (offset begin-mark) line-beginning-offset)) (when compress-whitespaces (let ((offset (buffer-search-backward (buffer begin-mark) (offset begin-mark) #(nil) :test #'(lambda (o1 o2) (declare (ignore o2)) (not (whitespacep syntax o1)))))) (when offset (delete-region begin-mark (1+ offset))))) (insert-object begin-mark #\Newline) (incf (offset begin-mark)) (let ((indentation (funcall syntax-line-indentation-function begin-mark))) (indent-line begin-mark indentation tab-width)) (beginning-of-line begin-mark) (setf line-beginning-offset (offset begin-mark)) (setf (offset walking-mark) (offset begin-mark)) (setf column 0)) (incf (offset walking-mark))))) (defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax &optional (compress-whitespaces t)) "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be mark<= `mark2.'" (let* ((buffer (buffer mark1))) (do-buffer-region (object offset buffer (offset mark1) (offset mark2)) (when (eql object #\Newline) (setf object #\Space))) (when (>= (buffer-display-column buffer (offset mark2) tab-width) (1- fill-column)) (fill-line mark2 syntax-line-indentation-function fill-column tab-width compress-whitespaces syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Indentation (defgeneric indent-line (mark indentation tab-width) (:documentation "Indent the line containing mark with indentation spaces. Use tabs and spaces if tab-width is not nil, otherwise use spaces only.")) (defun indent-line* (mark indentation tab-width left) (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) (loop until (end-of-buffer-p mark2) as object = (object-after mark2) while (or (eql object #\Space) (eql object #\Tab)) do (delete-range mark2 1)) (loop until (zerop indentation) do (cond ((and tab-width (>= indentation tab-width)) (insert-object mark2 #\Tab) (when left ; spaces must follow tabs (forward-object mark2)) (decf indentation tab-width)) (t (insert-object mark2 #\Space) (decf indentation)))))) (defmethod indent-line ((mark left-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width t)) (defmethod indent-line ((mark right-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width nil)) (defun delete-indentation (mark) (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (delete-range mark -1) (loop until (end-of-buffer-p mark) while (buffer-whitespacep (object-after mark)) do (delete-range mark 1)) (loop until (beginning-of-buffer-p mark) while (buffer-whitespacep (object-before mark)) do (delete-range mark -1)) (when (and (not (beginning-of-buffer-p mark)) (constituentp (object-before mark))) (insert-object mark #\Space))))

1 0

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

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2300 Modified Files: window-commands.lisp search-commands.lisp pane.lisp packages.lisp misc-commands.lisp lisp-syntax-commands.lisp gui.lisp file-commands.lisp editing.lisp developer-commands.lisp climacs.asd buffer-test.lisp base.lisp Log Message: Final major package-cleanup for now. New package, CLIMACS-CORE, added. Lots of commands moved from CLIMACS-GUI to CLIMACS-COMMANDS, reusable functions moved to CLIMACS-CORE. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/05/13 17:19:10 1.8 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 13:24:40 1.9 @@ -26,7 +26,7 @@ ;;; Windows commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/02 18:42:28 1.8 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 13:24:40 1.9 @@ -26,7 +26,7 @@ ;;; Search commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (defun display-string (string) (with-output-to-string (result) @@ -329,7 +329,9 @@ with length = (length string) with use-region-case = (no-upper-p string) for occurrences from 0 - while (query-replace-find-next-match point string) + while (let ((offset-before (offset point))) + (search-forward point string :test (case-relevant-test string)) + (/= (offset point) offset-before)) do (backward-object point length) (replace-one-string point length newstring use-region-case) finally (display-message "Replaced ~A occurrence~:P" occurrences)))) @@ -340,10 +342,19 @@ (make-command-table 'query-replace-climacs-table :errorp nil) -(defun query-replace-find-next-match (mark string) - (let ((offset-before (offset mark))) - (search-forward mark string :test (case-relevant-test string)) - (/= (offset mark) offset-before))) +(defun query-replace-find-next-match (state) + (with-accessors ((string string1) + (buffers buffers) + (mark mark)) state + (let ((offset-before (offset mark))) + (search-forward mark string :test (case-relevant-test string)) + (or (/= (offset mark) offset-before) + (unless (null (rest buffers)) + (pop buffers) + (switch-to-buffer (first buffers)) + (setf mark (point (first buffers))) + (beginning-of-buffer mark) + (query-replace-find-next-match state)))))) (define-command (com-query-replace :name t :command-table search-table) () (let* ((pane (current-window)) @@ -375,11 +386,13 @@ (point (point pane)) (occurrences 0)) (declare (special string1 string2 occurrences)) - (when (query-replace-find-next-match point string1) - (setf (query-replace-state pane) (make-instance 'query-replace-state - :string1 string1 - :string2 string2) - (query-replace-mode pane) t) + (setf (query-replace-state pane) (make-instance 'query-replace-state + :string1 string1 + :string2 string2 + :mark point + :buffers (list (buffer pane)))) + (when (query-replace-find-next-match (query-replace-state pane)) + (setf (query-replace-mode pane) t) (display-message "Replace ~A with ~A:" string1 string2) (simple-command-loop 'query-replace-climacs-table @@ -394,12 +407,15 @@ (define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) - (point (point pane)) - (string1-length (length string1))) - (backward-object point string1-length) - (replace-one-string point string1-length string2 (no-upper-p string1)) + (string1-length (length string1)) + (state (query-replace-state pane))) + (backward-object (mark state) string1-length) + (replace-one-string (mark state) + string1-length + string2 + (no-upper-p string1)) (incf occurrences) - (if (query-replace-find-next-match point string1) + (if (query-replace-find-next-match (query-replace-state pane)) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) @@ -410,10 +426,13 @@ () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) - (point (point pane)) - (string1-length (length string1))) - (backward-object point string1-length) - (replace-one-string point string1-length string2 (no-upper-p string1)) + (string1-length (length string1)) + (state (query-replace-state pane))) + (backward-object (mark state) string1-length) + (replace-one-string (mark state) + string1-length + string2 + (no-upper-p string1)) (incf occurrences) (setf (query-replace-mode pane) nil))) @@ -423,19 +442,21 @@ () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) - (point (point pane)) - (string1-length (length string1))) - (loop do (backward-object point string1-length) - (replace-one-string point string1-length string2 (no-upper-p string1)) - (incf occurrences) - while (query-replace-find-next-match point string1) - finally (setf (query-replace-mode pane) nil)))) + (string1-length (length string1)) + (state (query-replace-state pane))) + (loop do (backward-object (mark state) string1-length) + (replace-one-string (mark state) + string1-length + string2 + (no-upper-p string1)) + (incf occurrences) + while (query-replace-find-next-match (query-replace-state pane)) + finally (setf (query-replace-mode pane) nil)))) (define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) () (declare (special string1 string2)) - (let* ((pane (current-window)) - (point (point pane))) - (if (query-replace-find-next-match point string1) + (let ((pane (current-window))) + (if (query-replace-find-next-match (query-replace-state pane)) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) @@ -694,4 +715,4 @@ (multiple-query-replace-set-key '(#\y) 'com-multiple-query-replace-replace) (multiple-query-replace-set-key '(#\n) 'com-multiple-query-replace-skip) (multiple-query-replace-set-key '(#\.) 'com-multiple-query-replace-replace-and-quit) -(multiple-query-replace-set-key '(#\!) 'com-multiple-query-replace-replace-all) \ No newline at end of file +(multiple-query-replace-set-key '(#\!) 'com-multiple-query-replace-replace-all) --- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/21 06:25:45 1.45 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/24 13:24:40 1.46 @@ -183,7 +183,9 @@ (defclass query-replace-state () ((string1 :initarg :string1 :accessor string1) - (string2 :initarg :string2 :accessor string2))) + (string2 :initarg :string2 :accessor string2) + (buffers :initarg :buffers :accessor buffers) + (mark :initarg :mark :accessor mark))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/23 11:59:38 1.105 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 13:24:40 1.106 @@ -88,7 +88,6 @@ #:constituentp #:just-n-spaces #:buffer-whitespacep - #:forward-word #:backward-word #:buffer-region-case #:input-from-stream #:output-to-stream #:name-mixin #:name @@ -101,7 +100,6 @@ #:upcase-buffer-region #:upcase-region #:capitalize-buffer-region #:capitalize-region #:tabify-region #:untabify-region - #:indent-line #:delete-indentation #:*kill-ring*) (:documentation "Basic functionality built on top of the buffer protocol. Here is where we define slightly higher level @@ -186,7 +184,7 @@ #:isearch-state #:search-string #:search-mark #:search-forward-p #:search-success-p #:isearch-mode #:isearch-states #:isearch-previous-string - #:query-replace-state #:string1 #:string2 + #:query-replace-state #:string1 #:string2 #:buffers #:mark #:query-replace-mode #:region-visible-p #:with-undo @@ -302,14 +300,7 @@ ;; Sentences #:forward-delete-sentence #:backward-delete-sentence #:forward-kill-sentence #:backward-kill-sentence - #:transpose-sentences - - - #:downcase-word #:upcase-word #:capitalize-word - - #:indent-region - #:fill-line - #:fill-region) + #:transpose-sentences) (:documentation "Functions and facilities for changing the buffer contents by syntactical elements. The functions in this package are syntax-aware, and their behavior is based on the semantics @@ -318,51 +309,87 @@ to implement the editing commands.")) (defpackage :climacs-gui - (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-abbrev :climacs-syntax :climacs-motion - :climacs-kill-ring :climacs-pane :clim-extensions - :undo :esa :climacs-editing :climacs-motion) - ;;(:import-from :lisp-string) - (:export #:climacs ; Frame. + (:use :clim-lisp :clim :climacs-buffer :climacs-base + :climacs-abbrev :climacs-syntax :climacs-motion + :climacs-kill-ring :climacs-pane :clim-extensions + :undo :esa :climacs-editing :climacs-motion) + ;;(:import-from :lisp-string) + (:export #:climacs ; Frame. + + #:extended-pane + #:climacs-info-pane - ;; GUI functions follow. - #:current-window - #:current-point - #:current-buffer - #:current-buffer - #:point - #:syntax - #:mark - #:insert-character - #:base-table - #:buffer-table - #:case-table - #:comment-table - #:deletion-table - #:development-table - #:editing-table - #:fill-table - #:indent-table - #:info-table - #:marking-table - #:movement-table - #:pane-table - #:search-table - #:self-insert-table - #:window-table + ;; GUI functions follow. + #:current-window + #:current-point + #:current-buffer + #:current-point + #:point + #:syntax + #:mark + #:insert-character + #:switch-to-buffer + #:make-buffer + #:erase-buffer + #:buffer-pane-p + #:display-window - ;; Some configuration variables - #:*bg-color* - #:*fg-color* - #:*info-bg-color* - #:*info-fg-color* - #:*mini-bg-color* - #:*mini-fg-color*)) + ;; Some configuration variables + #:*bg-color* + #:*fg-color* + #:*info-bg-color* + #:*info-fg-color* + #:*mini-bg-color* + #:*mini-fg-color* + #:*with-scrollbars* + + ;; The command tables + #:global-climacs-table #:keyboard-macro-table #:climacs-help-table + #:base-table #:buffer-table #:case-table #:comment-table + #:deletion-table #:development-table #:editing-table + #:fill-table #:indent-table #:info-table #:marking-table + #:movement-table #:pane-table #:search-table #:self-insert-table + #:window-table + + ;; Other stuff + #:dabbrev-expansion-mark + #:original-prefix + #:prefix-start-offset + #:overwrite-mode + #:goal-column + )) + +(defpackage :climacs-core + (:use :clim-lisp :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring + :climacs-editing :climacs-gui :clim :climacs-abbrev) + (:export #:goto-position + #:goto-line + + #:possibly-fill-line + #:insert-character + #:back-to-indentation + #:delete-horizontal-space + #:indent-current-line + #:insert-pair + + #:downcase-word #:upcase-word #:capitalize-word + + #:indent-region + #:fill-line #:fill-region + + #:indent-line #:delete-indentation) + (:documentation "Package for editor functionality that is + syntax-aware, but yet not specific to certain + syntaxes. Contains stuff like indentation, filling and other + features that require a fairly high-level view of the + application, but are not solely GUI-specific.")) (defpackage :climacs-commands (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-editing - :climacs-gui :esa :climacs-kill-ring) + :climacs-gui :esa :climacs-kill-ring :climacs-pane + :climacs-abbrev :undo :climacs-core) (:export #:define-motion-commands #:define-deletion-commands #:define-editing-commands) --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/02 15:43:48 1.16 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 13:24:40 1.17 @@ -26,7 +26,7 @@ ;;; miscellaneous commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (define-command (com-overwrite-mode :name t :command-table editing-table) () "Toggle overwrite mode for the current mode. @@ -52,6 +52,11 @@ 'buffer-table '((#\~ :meta :shift))) +(defun set-fill-column (column) + (if (> column 1) + (setf (auto-fill-column (current-window)) column) + (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) + (define-command (com-set-fill-column :name t :command-table fill-table) ((column 'integer :prompt "Column Number:")) "Set the fill column to the specified value. @@ -65,45 +70,6 @@ 'fill-table '((#\x :control) (#\f))) -(defun set-fill-column (column) - (if (> column 1) - (setf (auto-fill-column (current-window)) column) - (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) - -(defun possibly-fill-line () - (let* ((pane (current-window)) - (buffer (buffer pane))) - (when (auto-fill-mode pane) - (let* ((fill-column (auto-fill-column pane)) - (point (point pane)) - (offset (offset point)) - (tab-width (tab-space-count (stream-default-view pane))) - (syntax (syntax buffer))) - (when (>= (buffer-display-column buffer offset tab-width) - (1- fill-column)) - (fill-line point - (lambda (mark) - (syntax-line-indentation mark tab-width syntax)) - fill-column - tab-width - (syntax buffer))))))) - -(defun insert-character (char) - (let* ((window (current-window)) - (point (point window))) - (unless (constituentp char) - (possibly-expand-abbrev point)) - (when (whitespacep (syntax (buffer window)) char) - (possibly-fill-line)) - (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) - (progn - (delete-range point) - (insert-object point char)) - (insert-object point char)))) - -(define-command com-self-insert ((count 'integer)) - (loop repeat count do (insert-character *current-gesture*))) - (define-command (com-zap-to-object :name t :command-table deletion-table) () "Prompt for an object and kill to the next occurence of that object after point. Characters can be entered in #\ format." @@ -271,16 +237,6 @@ (untabify-region (mark pane) (point pane) (tab-space-count (stream-default-view pane))))) -(defun indent-current-line (pane point) - (let* ((buffer (buffer pane)) - (view (stream-default-view pane)) - (tab-space-count (tab-space-count view)) - (indentation (syntax-line-indentation point - tab-space-count - (syntax buffer)))) - (indent-line point indentation (and (indent-tabs-mode buffer) - tab-space-count)))) - (define-command (com-indent-line :name t :command-table indent-table) () (let* ((pane (current-window)) (point (point pane))) @@ -410,12 +366,6 @@ 'marking-table '((#\x :control) (#\h))) -(defun back-to-indentation (mark syntax) - (beginning-of-line mark) - (loop until (end-of-line-p mark) - while (whitespacep syntax (object-after mark)) - do (forward-object mark))) - (define-command (com-back-to-indentation :name t :command-table movement-table) () "Move point to the first non-whitespace object on the current line. If there is no non-whitespace object, leaves point at the end of the line." @@ -426,17 +376,6 @@ 'movement-table '((#\m :meta))) -(defun delete-horizontal-space (mark syntax &optional (backward-only-p nil)) - (let ((mark2 (clone-mark mark))) - (loop until (beginning-of-line-p mark) - while (whitespacep syntax (object-before mark)) - do (backward-object mark)) - (unless backward-only-p - (loop until (end-of-line-p mark2) - while (whitespacep syntax (object-after mark2)) - do (forward-object mark2))) - (delete-region mark mark2))) - (define-command (com-delete-horizontal-space :name t :command-table deletion-table) ((backward-only-p 'boolean :prompt "Delete backwards only?")) @@ -450,37 +389,19 @@ 'deletion-table '((#\\ :meta))) -(defun just-one-space (mark syntax count) - (let (offset) - (loop until (beginning-of-line-p mark) - while (whitespacep syntax (object-before mark)) - do (backward-object mark)) - (loop until (end-of-line-p mark) - while (whitespacep syntax (object-after mark)) - repeat count do (forward-object mark) - finally (setf offset (offset mark))) - (loop until (end-of-line-p mark) - while (whitespacep syntax (object-after mark)) - do (forward-object mark)) - (delete-region offset mark))) - (define-command (com-just-one-space :name t :command-table deletion-table) ((count 'integer :prompt "Number of spaces")) "Delete whitespace around point, leaving a single space. With a positive numeric argument, leave that many spaces. FIXME: should distinguish between types of whitespace." - (just-one-space (point (current-window)) - (syntax (buffer (current-window))) - count)) + (just-n-spaces (point (current-window)) + count)) (set-key `(com-just-one-space ,*numeric-argument-marker*) 'deletion-table '((#\Space :meta))) -(defun goto-position (mark pos) - (setf (offset mark) pos)) - (define-command (com-goto-position :name t :command-table movement-table) ((position 'integer :prompt "Goto Position")) "Prompts for an integer, and sets the offset of point to that integer." @@ -488,18 +409,6 @@ (point (current-window)) position)) -(defun goto-line (mark line-number) - (loop with m = (clone-mark (low-mark (buffer mark)) - :right) - initially (beginning-of-buffer m) - do (end-of-line m) - until (end-of-buffer-p m) - repeat (1- line-number) - do (incf (offset m)) - (end-of-line m) - finally (beginning-of-line m) - (setf (offset mark) (offset m)))) - (define-command (com-goto-line :name t :command-table movement-table) ((line-number 'integer :prompt "Goto Line")) "Prompts for a line number, and sets point to the beginning of that line. @@ -671,7 +580,9 @@ (let* ((window (current-window)) (point (point window)) (syntax (syntax (buffer window)))) - (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) window + (with-accessors ((original-prefix original-prefix) + (prefix-start-offset prefix-start-offset) + (dabbrev-expansion-mark dabbrev-expansion-mark)) window (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) (offset point)) @@ -829,26 +740,6 @@ ;; (defparameter *insert-pair-alist* ;; '((#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) (#\" #\") (#\' #\') (#\` #\'))) -(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\))) - (cond ((> count 0) - (loop while (and (not (end-of-buffer-p mark)) - (whitespacep syntax (object-after mark))) - do (forward-object mark))) - ((< count 0) - (setf count (- count)) - (loop repeat count do (backward-expression mark syntax)))) - (unless (or (beginning-of-buffer-p mark) - (whitespacep syntax (object-before mark))) - (insert-object mark #\Space)) - (insert-object mark open) - (let ((here (clone-mark mark))) - (loop repeat count - do (forward-expression here syntax)) - (insert-object here close) - (unless (or (end-of-buffer-p here) - (whitespacep syntax (object-after here))) - (insert-object here #\Space)))) - (defun insert-parentheses (mark syntax count) (insert-pair mark syntax count #\( #\))) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 08:20:28 1.11 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 13:24:40 1.12 @@ -72,7 +72,7 @@ (when (typep token 'string-form) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token - (climacs-editing:fill-region (make-instance 'standard-right-sticky-mark + (climacs-core:fill-region (make-instance 'standard-right-sticky-mark :buffer implementation :offset offset1) (make-instance 'standard-right-sticky-mark @@ -94,7 +94,7 @@ (if (plusp count) (loop repeat count do (forward-expression mark syntax)) (loop repeat (- count) do (backward-expression mark syntax))) - (climacs-editing:indent-region pane (clone-mark point) mark))) + (climacs-core:indent-region pane (clone-mark point) mark))) (define-command (com-eval-last-expression :name t :command-table lisp-table) ((insertp 'boolean :prompt "Insert?")) @@ -106,7 +106,7 @@ (with-syntax-package syntax mark (package) (let ((*package* package) (*read-base* (base syntax))) - (climacs-gui::com-eval-expression + (climacs-commands::com-eval-expression (token-to-object syntax token :read t) insertp))) (esa:display-message "Nothing to evaluate.")))) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/22 20:35:06 1.222 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 13:24:40 1.223 @@ -30,12 +30,12 @@ (defclass extended-pane (climacs-pane esa-pane-mixin) (;; for next-line and previous-line commands - (goal-column :initform nil) + (goal-column :initform nil :accessor goal-column) ;; for dynamic abbrev expansion - (original-prefix :initform nil) - (prefix-start-offset :initform nil) - (dabbrev-expansion-mark :initform nil) - (overwrite-mode :initform nil))) + (original-prefix :initform nil :accessor original-prefix) + (prefix-start-offset :initform nil :accessor prefix-start-offset) + (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) + (overwrite-mode :initform nil :accessor overwrite-mode))) (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -128,7 +128,6 @@ (define-application-frame climacs (standard-application-frame esa-frame-mixin) ((buffers :initform '() :accessor buffers)) - (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table @@ -369,6 +368,9 @@ 'base-table '((#\c :control) (#\l :control))) +(define-command com-self-insert ((count 'integer)) + (loop repeat count do (insert-character *current-gesture*))) + (loop for code from (char-code #\Space) to (char-code #\~) do (set-key `(com-self-insert ,*numeric-argument-marker*) 'self-insert-table --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/12 19:10:58 1.20 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/24 13:24:40 1.21 @@ -26,7 +26,7 @@ ;;; File commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (defun filename-completer (so-far mode) (flet ((remove-trail (s) --- /project/climacs/cvsroot/climacs/editing.lisp 2006/07/21 05:08:26 1.3 +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/24 13:24:40 1.4 @@ -264,126 +264,3 @@ (define-edit-fns expression) (define-edit-fns definition) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Character case - -(defun downcase-word (mark &optional (n 1)) - "Convert the next N words to lowercase, leaving mark after the last word." - (let ((syntax (syntax (buffer mark)))) - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (downcase-region offset mark))))) - -(defun upcase-word (mark syntax &optional (n 1)) - "Convert the next N words to uppercase, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (upcase-region offset mark)))) - -(defun capitalize-word (mark &optional (n 1)) - "Capitalize the next N words, leaving mark after the last word." - (let ((syntax (syntax (buffer mark)))) - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (capitalize-region offset mark))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Indentation - -(defun indent-region (pane mark1 mark2) - "Indent all lines in the region delimited by `mark1' and `mark2' - according to the rules of the active syntax in `pane'." - (let* ((buffer (buffer pane)) - (view (clim:stream-default-view pane)) - (tab-space-count (tab-space-count view)) - (tab-width (and (indent-tabs-mode buffer) - tab-space-count)) - (syntax (syntax buffer))) - (do-buffer-region-lines (line mark1 mark2) - (let ((indentation (syntax-line-indentation - line - tab-space-count - syntax))) - (indent-line line indentation tab-width)) - ;; We need to update the syntax every time we perform an - ;; indentation, so that subsequent indentations will be - ;; correctly indented (this matters in list forms). FIXME: This - ;; should probably happen automatically. - (update-syntax buffer syntax)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Auto fill - -(defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax - &optional (compress-whitespaces t)) - "Breaks the contents of line pointed to by MARK up to MARK into -multiple lines such that none of them is longer than FILL-COLUMN. If -COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the -decision is made to break the line at a point. For now, the -compression means just the deletion of trailing whitespaces." - (let ((begin-mark (clone-mark mark))) - (beginning-of-line begin-mark) - (loop with column = 0 - with line-beginning-offset = (offset begin-mark) - with walking-mark = (clone-mark begin-mark) - while (mark< walking-mark mark) - as object = (object-after walking-mark) - do (case object - (#\Space - (setf (offset begin-mark) (offset walking-mark)) - (incf column)) - (#\Tab - (setf (offset begin-mark) (offset walking-mark)) - (incf column (- tab-width (mod column tab-width)))) - (t - (incf column))) - (when (and (>= column fill-column) - (/= (offset begin-mark) line-beginning-offset)) - (when compress-whitespaces - (let ((offset (buffer-search-backward - (buffer begin-mark) - (offset begin-mark) - #(nil) - :test #'(lambda (o1 o2) - (declare (ignore o2)) - (not (whitespacep syntax o1)))))) - (when offset - (delete-region begin-mark (1+ offset))))) - (insert-object begin-mark #\Newline) - (incf (offset begin-mark)) - (let ((indentation - (funcall syntax-line-indentation-function begin-mark))) - (indent-line begin-mark indentation tab-width)) - (beginning-of-line begin-mark) - (setf line-beginning-offset (offset begin-mark)) - (setf (offset walking-mark) (offset begin-mark)) - (setf column 0)) - (incf (offset walking-mark))))) - -(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax - &optional (compress-whitespaces t)) - "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be -mark<= `mark2.'" - (let* ((buffer (buffer mark1))) - (do-buffer-region (object offset buffer - (offset mark1) (offset mark2)) - (when (eql object #\Newline) - (setf object #\Space))) - (when (>= (buffer-display-column buffer (offset mark2) tab-width) - (1- fill-column)) - (fill-line mark2 - syntax-line-indentation-function - fill-column - tab-width - compress-whitespaces - syntax)))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/03/03 19:38:57 1.2 +++ /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/07/24 13:24:40 1.3 @@ -26,7 +26,7 @@ ;;; Commands for developing the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (define-command (com-reset-profile :name t :command-table development-table) () #+sbcl (sb-profile:reset) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/11 14:20:20 1.47 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/24 13:24:40 1.48 @@ -86,14 +86,16 @@ "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" "window-commands" "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" "misc-commands" "window-commands" "file-commands")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" + "misc-commands" "window-commands" "file-commands" "core")) #.(if (find-swank) '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" "abbrev" "editing" "motion")) - (:file "climacs" :depends-on ("gui")) + (:file "core" :depends-on ("gui")) + (:file "climacs" :depends-on ("gui" "core")) ;; (:file "buffer-commands" :depends-on ("gui")) (:file "developer-commands" :depends-on ("gui" "lisp-syntax")) (:file "motion-commands" :depends-on ("gui")) @@ -111,7 +113,7 @@ :components ((:file "rt" :pathname #p"testing/rt.lisp") (:file "buffer-test" :depends-on ("rt")) - (:file "base-test" :depends-on ("rt")) + (:file "base-test" :depends-on ("rt" "buffer-test")) (:module "cl-automaton" :depends-on ("rt") --- /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/08 00:11:22 1.22 +++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/24 13:24:40 1.23 @@ -4,7 +4,8 @@ ;;; (cl:defpackage :climacs-tests - (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion :climacs-editing :automaton)) + (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion + :climacs-editing :automaton :climacs-core)) (cl:in-package :climacs-tests) --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/23 11:57:10 1.55 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 13:24:40 1.56 @@ -666,52 +666,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Indentation - -(defgeneric indent-line (mark indentation tab-width) - (:documentation "Indent the line containing mark with indentation -spaces. Use tabs and spaces if tab-width is not nil, otherwise use -spaces only.")) - -(defun indent-line* (mark indentation tab-width left) - (let ((mark2 (clone-mark mark))) - (beginning-of-line mark2) - (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (delete-range mark2 1)) - (loop until (zerop indentation) - do (cond ((and tab-width (>= indentation tab-width)) - (insert-object mark2 #\Tab) - (when left ; spaces must follow tabs - (forward-object mark2)) - (decf indentation tab-width)) - (t - (insert-object mark2 #\Space) - (decf indentation)))))) - -(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width t)) - -(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width nil)) - -(defun delete-indentation (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (buffer-whitespacep (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (buffer-whitespacep (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Kill ring (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))

1 0

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

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28737 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Non-10 bases should work properly now. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/23 20:31:56 1.97 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 08:20:27 1.98 @@ -72,8 +72,7 @@ designator in the form. The list is sorted with the earliest (in-package) forms last (descending offset).") - (base :accessor base - :initform 10 + (base :initform nil :documentation "The base which numbers in the buffer are expected to be in.") (option-specified-package :accessor option-specified-package @@ -91,6 +90,13 @@ (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) +(defgeneric base (syntax) + (:documentation "Get the base `syntax' should interpret numbers + in.") + (:method ((syntax lisp-syntax)) + (or (slot-value syntax 'base) + *read-base*))) + (define-option-for-syntax lisp-syntax "Package" (syntax package-name) (let ((specified-package (find-package package-name))) (setf (option-specified-package syntax) (or specified-package package-name)))) @@ -160,7 +166,8 @@ the source code.") (:method (image form buffer buffer-mark) (compile-string-for-climacs image - (write-to-string form) + (let ((*print-base* (base (syntax buffer)))) + (write-to-string form)) *package* buffer buffer-mark))) (defgeneric compile-file-for-climacs (image filepath package &optional load-p) @@ -3086,23 +3093,26 @@ (defun eval-region (start end syntax) ;; Must be (mark>= end start). - (with-slots (package) syntax - (let* ((string (buffer-substring (buffer start) - (offset start) - (offset end))) - (values (multiple-value-list - (eval-string syntax string))) - ;; Enclose each set of values in {}. - (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" - values))) - (esa:display-message result)))) + (with-syntax-package syntax start (package) + (let ((*package* package) + (*read-base* (base syntax))) + (let* ((string (buffer-substring (buffer start) + (offset start) + (offset end))) + (values (multiple-value-list + (eval-string syntax string))) + ;; Enclose each set of values in {}. + (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" + values))) + (esa:display-message result))))) (defun compile-definition-interactively (mark syntax) (with-syntax-package syntax mark (package) (let* ((token (definition-at-mark mark syntax)) (string (token-string syntax token)) (m (clone-mark mark)) - (buffer-name (name (buffer syntax)))) + (buffer-name (name (buffer syntax))) + (*read-base* (base syntax))) (forward-definition m syntax) (backward-definition m syntax) (multiple-value-bind (result notes) @@ -3122,12 +3132,13 @@ (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) (climacs-gui::save-buffer buffer)) (with-syntax-package (syntax buffer) 0 (package) - (multiple-value-bind (result notes) - (compile-file-for-climacs (get-usable-image (syntax buffer)) - (filepath buffer) - package load-p) - (show-note-counts notes (second result)) - (when notes (show-notes notes (name buffer) ""))))) + (let ((*read-base* (base (syntax buffer)))) + (multiple-value-bind (result notes) + (compile-file-for-climacs (get-usable-image (syntax buffer)) + (filepath buffer) + package load-p) + (show-note-counts notes (second result)) + (when notes (show-notes notes (name buffer) "")))))) ;;; Parameter hinting --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/23 20:31:56 1.10 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 08:20:28 1.11 @@ -104,7 +104,8 @@ (token (form-before syntax (offset mark)))) (if token (with-syntax-package syntax mark (package) - (let ((*package* package)) + (let ((*package* package) + (*read-base* (base syntax))) (climacs-gui::com-eval-expression (token-to-object syntax token :read t) insertp))) @@ -141,9 +142,8 @@ (point (point (current-window)))) (when (mark> mark point) (rotatef mark point)) - (evaluating-interactively - (eval-region mark point - (syntax (buffer (current-window))))))) + (eval-region mark point + (syntax (buffer (current-window)))))) (define-command (com-compile-definition :name t :command-table lisp-table) ()

1 0

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

23 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3885 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Many changes, but CVS makes it too painful to break it up into smaller patches (/me wishes for more modern VCS). The highlights are: * Symbol completion should no longer nuke quoting. * Symbol completion is now more intelligent with respect to completion of keywords for keyword arguments. * Changed some form selection functions to accept offsets as well as marks (using the `as-offsets' macro). * Realized that this syntax is becoming quite complex, slight refactoring is needed. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 22:12:04 1.96 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/23 20:31:56 1.97 @@ -1305,17 +1305,15 @@ found, return the package specified in the attribute list. If no package can be found at all, or the otherwise found packages are invalid, return the CLIM-USER package." - (let* ((mark-offset (if (numberp mark-or-offset) - mark-or-offset - (offset mark-or-offset))) - (designator (rest (find mark-offset (package-list syntax) - :key #'first - :test #'>=)))) - (or (handler-case (find-package designator) - (type-error () + (as-offsets ((mark-or-offset offset)) + (let* ((designator (rest (find offset (package-list syntax) + :key #'first + :test #'>=)))) + (or (handler-case (find-package designator) + (type-error () nil)) - (find-package (option-specified-package syntax)) - (find-package :clim-user)))) + (find-package (option-specified-package syntax)) + (find-package :clim-user))))) (defmacro with-syntax-package (syntax offset (package-sym) &body body) @@ -1489,8 +1487,6 @@ (:method (form syntax) nil)) (defmethod form-operands ((form list-form) syntax) - ;; If *anything' goes wrong, just assume that we could not find any - ;; operands and return nil. (mapcar #'(lambda (operand) (if (typep operand 'form) (token-to-object syntax operand :no-error t))) @@ -1517,60 +1513,64 @@ ;;; ;;; Useful functions for selecting forms based on the mark. -(defun expression-at-mark (mark syntax) - "Return the form at `mark'. If `mark' is just after, +(defun expression-at-mark (mark-or-offset syntax) + "Return the form at `mark-or-offset'. If `mark-or-offset' is just after, or inside, a top-level-form, or if there are no forms after -`mark', the form preceding `mark' is returned. Otherwise, the -form following `mark' is returned." - (or (form-around syntax (offset mark)) - (form-after syntax (offset mark)) - (form-before syntax (offset mark)))) - -(defun definition-at-mark (mark syntax) - "Return the top-level form at `mark'. If `mark' is just after, -or inside, a top-level-form, or if there are no forms after -`mark', the top-level-form preceding `mark' is -returned. Otherwise, the top-level-form following `mark' is +`mark-or-offset', the form preceding `mark-or-offset' is +returned. Otherwise, the form following `mark-or-offset' is returned." - (form-toplevel (expression-at-mark mark syntax) syntax)) + (as-offsets ((mark-or-offset offset)) + (or (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset)))) -(defun symbol-at-mark (mark syntax) - "Return a symbol token at mark. This function will \"unwrap\" - quote-forms in order to return the symbol token. If no symbol - token can be found, NIL will be returned." +(defun definition-at-mark (mark-or-offset syntax) + "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, +or inside, a top-level-form, or if there are no forms after +`mark-or-offset', the top-level-form preceding `mark-or-offset' +is returned. Otherwise, the top-level-form following +`mark-or-offset' is returned." + (form-toplevel (expression-at-mark mark-or-offset syntax) syntax)) + +(defun symbol-at-mark (mark-or-offset syntax) + "Return a symbol token at `mark-or-offset'. This function will + \"unwrap\" quote-forms in order to return the symbol token. If + no symbol token can be found, NIL will be returned." (labels ((unwrap-form (form) (cond ((typep form 'quote-form) (unwrap-form (first-form (children form)))) ((typep form 'complete-token-lexeme) form)))) - (unwrap-form (expression-at-mark mark syntax)))) + (unwrap-form (expression-at-mark mark-or-offset syntax)))) -(defun this-form (mark syntax) - "Return a form at mark. This function defines which +(defun this-form (mark-or-offset syntax) + "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." - (or (form-around syntax (offset mark)) - (form-before syntax (offset mark)))) - -(defun preceding-form (mark syntax) - "Return a form at mark." - (or (form-before syntax (offset mark)) - (form-around syntax (offset mark)))) + (as-offsets ((mark-or-offset offset)) + (or (form-around syntax offset) + (form-before syntax offset)))) + +(defun preceding-form (mark-or-offset syntax) + "Return a form at `mark-or-offset'." + (as-offsets ((mark-or-offset offset)) + (or (form-before syntax offset) + (form-around syntax offset)))) (defun text-of-definition-at-mark (mark syntax) "Return the text of the definition at mark." (let ((definition (definition-at-mark mark syntax))) (buffer-substring (buffer mark) - (start-offset definition) + (start-offset definition) (end-offset definition)))) -(defun text-of-expression-at-mark (mark syntax) - "Return the text of the expression at mark." - (let ((expression (expression-at-mark mark syntax))) +(defun text-of-expression-at-mark (mark-or-offset syntax) + "Return the text of the expression at `mark-or-offset'." + (let ((expression (expression-at-mark mark-or-offset syntax))) (token-string syntax expression))) -(defun symbol-name-at-mark (mark syntax) - "Return the text of the symbol at mark." - (let ((token (symbol-at-mark mark syntax))) +(defun symbol-name-at-mark (mark-or-offset syntax) + "Return the text of the symbol at `mark-or-offset'." + (let ((token (symbol-at-mark mark-or-offset syntax))) (when token (token-string syntax token)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1581,8 +1581,7 @@ "Replace the symbol at `mark' with `string' and move `mark' to after `string'." (let ((token (symbol-at-mark mark syntax))) - (unless (= (offset mark) (start-offset token)) - (backward-expression mark syntax 1 nil)) + (setf (offset mark) (start-offset token)) (forward-kill-expression mark syntax) (insert-sequence mark string))) @@ -1844,15 +1843,15 @@ (should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset) (= (the fixnum (start-offset parse-symbol)) point-offset)))) (if should-highlight - (with-text-face (pane :bold) - (display-parse-tree (car children) syntax pane)) - (display-parse-tree (car children) syntax pane)) + (with-text-face (pane :bold) + (display-parse-tree (car children) syntax pane)) + (display-parse-tree (car children) syntax pane)) (loop for child-list on (cdr children) if (and should-highlight (null (cdr child-list))) do - (with-text-face (pane :bold) - (display-parse-tree (car child-list) syntax pane)) - else do - (display-parse-tree (car child-list) syntax pane)))) + (with-text-face (pane :bold) + (display-parse-tree (car child-list) syntax pane)) + else do + (display-parse-tree (car child-list) syntax pane)))) (defmethod display-parse-tree ((parse-symbol incomplete-list-form) (syntax lisp-syntax) pane) (let* ((children (children parse-symbol)) @@ -3559,44 +3558,42 @@ (defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." - (let* ((offset (if (numberp mark-or-offset) - mark-or-offset - (offset mark-or-offset))) - (preceding-arg-token (form-before syntax offset)) - (indexing-start-arg - (let* ((candidate-before preceding-arg-token) - (candidate-after (when (null candidate-before) - (let ((after (form-after syntax offset))) - (when after - (parent after))))) - (candidate-around (when (null candidate-after) - (form-around syntax offset))) - (candidate (or candidate-before - candidate-after - candidate-around))) - (if (or (and candidate-before - (typep candidate-before 'incomplete-list-form)) - (and (null candidate-before) - (typep (or candidate-after candidate-around) - 'list-form))) - ;; HACK: We should not attempt to find the location of - ;; the list form itself, so we create a new parser - ;; symbol, attach the list form as a parent and try to - ;; find the new symbol. That way we can get a list of - ;; argument-indices to the first element of the list - ;; form, even if it is empty or incomplete. - (let ((obj (make-instance 'parser-symbol))) - (setf (parent obj) candidate) - obj) - candidate))) - (argument-indices (find-argument-indices-for-operand - syntax - indexing-start-arg - operator-form)) - (preceding-arg-obj (when preceding-arg-token - (token-to-object syntax preceding-arg-token - :no-error t)))) - (values preceding-arg-obj argument-indices))) + (as-offsets ((mark-or-offset offset)) + (let* ((preceding-arg-token (form-before syntax offset)) + (indexing-start-arg + (let* ((candidate-before preceding-arg-token) + (candidate-after (when (null candidate-before) + (let ((after (form-after syntax offset))) + (when after + (parent after))))) + (candidate-around (when (null candidate-after) + (form-around syntax offset))) + (candidate (or candidate-before + candidate-after + candidate-around))) + (if (or (and candidate-before + (typep candidate-before 'incomplete-list-form)) + (and (null candidate-before) + (typep (or candidate-after candidate-around) + 'list-form))) + ;; HACK: We should not attempt to find the location of + ;; the list form itself, so we create a new parser + ;; symbol, attach the list form as a parent and try to + ;; find the new symbol. That way we can get a list of + ;; argument-indices to the first element of the list + ;; form, even if it is empty or incomplete. + (let ((obj (make-instance 'parser-symbol))) + (setf (parent obj) candidate) + obj) + candidate))) + (argument-indices (find-argument-indices-for-operand + syntax + indexing-start-arg + operator-form)) + (preceding-arg-obj (when preceding-arg-token + (token-to-object syntax preceding-arg-token + :no-error t)))) + (values preceding-arg-obj argument-indices)))) (defun valid-operator-p (operator) "Check whether or not `operator' is a valid @@ -3654,9 +3651,9 @@ (when (parent form) (recurse (parent form))))) -(defmacro with-code-insight (mark syntax (&key operator preceding-operand - form preceding-operand-indices - operands) +(defmacro with-code-insight (mark-or-offset syntax (&key operator preceding-operand + form preceding-operand-indices + operands) &body body) "Evaluate `body' with the provided symbols lexically bound to interesting details about the code at `mark'. If `mark' is not @@ -3669,7 +3666,7 @@ ;; My kingdom for with-gensyms (or once-only)! (mark-value-sym (gensym)) (syntax-value-sym (gensym))) - `(let* ((,mark-value-sym ,mark) + `(let* ((,mark-value-sym ,mark-or-offset) (,syntax-value-sym ,syntax) (,form-sym ;; Find a form with a valid (fboundp) operator. @@ -3683,35 +3680,38 @@ ;; cannot find a form with a valid operator, just ;; return the form `mark' is in. (unless (null immediate-form) - (labels ((recurse (form) - (unless (null (parent form)) - (or (unless (eq (first-form (children (parent form))) - form) - (recurse (parent form))) - (and (valid-operator-p (form-operator - form - ,syntax-value-sym)) - (indices-match-arglist - (arglist-for-form - (form-operator - form - ,syntax-value-sym) - (form-operands - form - ,syntax-value-sym)) - (second - (multiple-value-list - (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) - (not (direct-arg-p form ,syntax-value-sym)) - form))))) - (or (recurse (parent immediate-form)) - (parent immediate-form)))))) + (labels ((recurse (form) + (unless (null (parent form)) + (or (unless (eq (first-form (children (parent form))) + form) + (recurse (parent form))) + (and (valid-operator-p (form-operator + form + ,syntax-value-sym)) + (indices-match-arglist + (arglist-for-form + (form-operator + form + ,syntax-value-sym) + (form-operands + form + ,syntax-value-sym)) + (second + (multiple-value-list + (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) + (not (direct-arg-p form ,syntax-value-sym)) + form))))) + (or (recurse (parent immediate-form)) + (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym))) (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym)))) + (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym + ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym)) + (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) ,@body)))) (defun show-arglist-for-form-at-mark (mark syntax) @@ -3824,6 +3824,103 @@ (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 + operator that has the argument list `arglist'." + (let* ((key-position (position '&key arglist)) + (cleaned-arglist (remove-if #'arglist-keyword-p + arglist)) + (index (first arg-indices)) + (difference (- (length arglist) + (length cleaned-arglist)))) + (cond ((and (null key-position) + (rest arg-indices) + (> (length cleaned-arglist) + index) + (listp (elt cleaned-arglist index))) + ;; Look in a nested argument list. + (relevant-keywords (elt cleaned-arglist index) + (rest arg-indices))) + ((and (not (null key-position)) + (>= (+ index + difference) + key-position) + (not (evenp (- index key-position difference)))) + (mapcar #'unlisted (subseq cleaned-arglist + (- key-position + difference + -1))))))) + +(defun completions-from-keywords (syntax token) + "Assume that `token' is a (partial) keyword argument +keyword. Find out which operator it is applicable to, and return +a completion list based on the valid keywords, or NIL, if no +keyword arguments would be valid (for example, if the operator +doesn't take keyword arguments)." + (with-code-insight (start-offset token) syntax + (:preceding-operand-indices poi + :operator operator) + (when (valid-operator-p operator) + (let* ((relevant-keywords + (relevant-keywords (arglist-for-form operator) + poi)) + (completions (simple-completions + (get-usable-image syntax) + (token-string syntax token) + +keyword-package+)) + (relevant-completions + (remove-if-not #'(lambda (compl) + (member compl relevant-keywords + :test #'(lambda (a b) + (string-equal a b + :start1 1)) + :key #'symbol-name)) + (mapcar #'string-downcase (first completions))))) + (list relevant-completions + (longest-completion relevant-completions)))))) + +;; The following stuff is from Swank. + +(defun longest-completion (completions) + "Return the longest completion of `completions', which must be a +list of sequences." [76 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/21 06:15:40 1.9 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/23 20:31:56 1.10 @@ -254,11 +254,11 @@ (buffer (buffer pane)) (syntax (syntax buffer)) (mark (point pane)) - (name (symbol-name-at-mark mark - syntax))) - (when name + (token (symbol-at-mark mark + syntax))) + (when token (with-syntax-package syntax mark (package) - (let ((completion (show-completions syntax name package))) + (let ((completion (show-completions syntax token package))) (unless (= (length completion) 0) (replace-symbol-at-mark mark syntax completion)))))))

1 0

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

23 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31341 Modified Files: packages.lisp Log Message: Export the `as-offsets' macro from :climacs-base. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/11 14:20:20 1.104 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/23 11:59:38 1.105 @@ -75,7 +75,8 @@ (defpackage :climacs-base (:use :clim-lisp :climacs-buffer :climacs-kill-ring) - (:export #:do-buffer-region + (:export #:as-offsets + #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line #:open-line

1 0

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

23 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31285 Modified Files: base.lisp Log Message: Added `as-offsets' macro for ease of writing functions that accept both offsets and marks. --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/07 23:59:38 1.54 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/23 11:57:10 1.55 @@ -32,6 +32,30 @@ (in-package :climacs-base) +(defmacro as-offsets ((&rest marks) + &body body) + "Bind the symbols in `marks' to the numeric offsets of the mark + objects that the symbols are bound to. If a symbol in `mark' is + already bound to an offset, just keep that binding. An element + of `marks' may also be a list - in this case, the first element + is used to get an offset, and the second element (which should + be a symbol) will be bound to this offset. Evaluate `body' with + these bindings." + `(let ,(mapcar #'(lambda (mark-sym) + (if (listp mark-sym) + `(,(second mark-sym) + (let ((value ,(first mark-sym))) + (if (numberp value) + value + (offset value)))) + `(,mark-sym + (let ((value ,mark-sym)) + (if (numberp value) + ,mark-sym + (offset value)))))) + marks) + ,@body)) + (defmacro do-buffer-region ((object offset buffer offset1 offset2) &body body) "Iterate over the elements of the region delimited by offset1 and offset2.

1 0

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

22 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25909 Modified Files: lisp-syntax.lisp Log Message: Fixed some more issues regarding intelligent parameter hinting. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 16:48:20 1.95 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 22:12:04 1.96 @@ -2526,7 +2526,8 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level - (let* ((arglist (when (fboundp symbol) (arglist (get-usable-image syntax) symbol))) + (let* ((arglist (when (fboundp symbol) + (arglist-for-form symbol))) (body-or-rest-pos (or (position '&body arglist) (position '&rest arglist)))) (if (and (or (macro-function symbol) @@ -3325,66 +3326,47 @@ for arg-name = (unlisted arg-element) for index from 0 - with in-&aux ; If non-NIL, we are in the - ; &aux parameters that should - ; not be displayed. - - with in-garbage ; If non-NIL, the next - ; argument is a garbage - ; parameter that should not be - ; displayed. - if (eq arg-element '&aux) - do (setf in-&aux t) - else if (member arg-element +cl-garbage-keywords+ :test #'eq) - do (setf in-garbage t) - else if (and (listp arg-element) + if (and (listp arg-element) (> mandatory-argument-count - index) - (not in-garbage) - (not in-&aux)) - collect (multiple-value-bind (arglist - sublist-emphasized-symbols - sublist-highlighted-symbols) - (analyze-arglist arg-element - (rest current-arg-indices) - preceding-arg - (when (< index (length provided-args)) - (listed (elt provided-args index)))) - ;; Unless our `current-arg-index' - ;; actually refers to this sublist, its - ;; highlighted and emphasized symbols - ;; are ignored. Also, if - ;; `current-arg-indices' is nil, we do - ;; not have enough information to - ;; properly highlight symbols in the - ;; arglist. - (when (and current-arg-indices - (= index current-arg-index)) - (if (and (rest current-arg-indices)) - (setf emphasized-symbols - (union (mapcar #'unlisted - sublist-emphasized-symbols) - emphasized-symbols) - highlighted-symbols - (union sublist-highlighted-symbols - highlighted-symbols)) - (setf emphasized-symbols + index)) + collect (multiple-value-bind (arglist + sublist-emphasized-symbols + sublist-highlighted-symbols) + (analyze-arglist arg-element + (rest current-arg-indices) + preceding-arg + (when (< index (length provided-args)) + (listed (elt provided-args index)))) + ;; Unless our `current-arg-index' + ;; actually refers to this sublist, its + ;; highlighted and emphasized symbols + ;; are ignored. Also, if + ;; `current-arg-indices' is nil, we do + ;; not have enough information to + ;; properly highlight symbols in the + ;; arglist. + (when (and current-arg-indices + (= index current-arg-index)) + (if (and (rest current-arg-indices)) + (setf emphasized-symbols + (union (mapcar #'unlisted + sublist-emphasized-symbols) + emphasized-symbols) + highlighted-symbols + (union sublist-highlighted-symbols + highlighted-symbols)) + (setf emphasized-symbols (union (mapcar #'unlisted arg-element) emphasized-symbols)))) - arglist) - else if (and (assoc arg-name user-supplied-arg-values) - (not in-garbage) - (not in-&aux)) - collect (list arg-name - (rest (assoc - arg-name - user-supplied-arg-values))) + arglist) + else if (assoc arg-name user-supplied-arg-values) + collect (list arg-name + (rest (assoc + arg-name + user-supplied-arg-values))) else - if in-garbage - do (setf in-garbage nil) - else if (not in-&aux) - collect arg-element))) + collect arg-element))) (setf ret-arglist (generate-arglist arglist))) (list ret-arglist emphasized-symbols highlighted-symbols))) @@ -3411,12 +3393,35 @@ preceding-arg provided-args))) +(defun cleanup-arglist (arglist) + "Remove elements of `arglist' that we are not interested in." + (loop + for arg in arglist + with in-&aux ; If non-NIL, we are in the + ; &aux parameters that should + ; not be displayed. + + with in-garbage ; If non-NIL, the next + ; argument is a garbage + ; parameter that should not be + ; displayed. + if in-garbage + do (setf in-garbage nil) + else if (not in-&aux) + if (eq arg '&aux) + do (setf in-&aux t) + else if (member arg +cl-garbage-keywords+ :test #'eq) + do (setf in-garbage t) + else + collect arg)) + (defgeneric arglist-for-form (operator &optional arguments) (:documentation "Return an arglist for `operator'") (:method (operator &optional arguments) (declare (ignore arguments)) - (arglist (get-usable-image (syntax (current-buffer))) operator))) + (cleanup-arglist + (arglist (get-usable-image (syntax (current-buffer))) operator)))) ;; Proof of concept, just to make sure it can be done. Also, we need a ;; more elegant interface. Perhaps it could be integrated with the @@ -3440,7 +3445,7 @@ (defmethod arglist-for-form ((operator list) &optional arguments) (declare (ignore arguments)) (case (first operator) - ('cl:lambda (second operator)))) + ('cl:lambda (cleanup-arglist (second operator))))) (defgeneric operator-for-display (operator) (:documentation "Return what should be displayed whenever @@ -3621,7 +3626,7 @@ (listp arg) (rest arg-indices)) (indices-match-arglist arg (rest arg-indices))) - (t (null (rest arg-indices)))))) + (t t)))) (defun direct-arg-p (form syntax) "Check whether `form' is a direct argument to one of its @@ -3679,21 +3684,26 @@ ;; return the form `mark' is in. (unless (null immediate-form) (labels ((recurse (form) - (unless (null form) - (if (and (valid-operator-p (form-operator + (unless (null (parent form)) + (or (unless (eq (first-form (children (parent form))) + form) + (recurse (parent form))) + (and (valid-operator-p (form-operator form ,syntax-value-sym)) (indices-match-arglist - (arglist (image ,syntax-value-sym) - (form-operator - form - ,syntax-value-sym)) + (arglist-for-form + (form-operator + form + ,syntax-value-sym) + (form-operands + form + ,syntax-value-sym)) (second (multiple-value-list - (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) - (or (recurse (parent form)) - (unless (direct-arg-p form ,syntax-value-sym) - form)))))) + (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) + (not (direct-arg-p form ,syntax-value-sym)) + form))))) (or (recurse (parent immediate-form)) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking

1 0

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

22 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv14065 Modified Files: gui.lisp Log Message: C-x C-b now behaves as an Emacs user would expect. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/21 06:25:45 1.221 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/22 20:35:06 1.222 @@ -432,9 +432,9 @@ (let* ((buffers (buffers *application-frame*)) (position (position buffer buffers)) (pane (current-window))) - (if position - (rotatef (car buffers) (nth position buffers)) - (push buffer (buffers *application-frame*))) + (when position + (setf buffers (delete buffer buffers))) + (push buffer (buffers *application-frame*)) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer pane) buffer) (full-redisplay pane)

1 0

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

22 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv10051 Modified Files: lisp-syntax.lisp Log Message: Fixed bug accidentaly introduced by last commit. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 15:59:25 1.94 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 16:48:20 1.95 @@ -3692,8 +3692,7 @@ (multiple-value-list (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) (or (recurse (parent form)) - (unless (and (typep form 'complete-token-lexeme) - (direct-arg-p form ,syntax-value-sym)) + (unless (direct-arg-p form ,syntax-value-sym) form)))))) (or (recurse (parent immediate-form)) (parent immediate-form))))))

1 0

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

22 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4596 Modified Files: lisp-syntax.lisp Log Message: Fixed how `indices-match-arglist' handles nonmandatory arguments. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 11:35:28 1.93 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 15:59:25 1.94 @@ -3614,11 +3614,14 @@ (pure-arglist (remove-if #'arglist-keyword-p arglist)) (arg (when (< index (length pure-arglist)) (elt pure-arglist index)))) - (if (and (not (null arg)) - (listp arg) - (rest arg-indices)) - (indices-match-arglist arg (rest arg-indices)) - (null (rest arg-indices))))) + (cond ((and (> index (or (position #'arglist-keyword-p arglist) 0)) + (not (null (rest arg-indices)))) + nil) + ((and (not (null arg)) + (listp arg) + (rest arg-indices)) + (indices-match-arglist arg (rest arg-indices))) + (t (null (rest arg-indices)))))) (defun direct-arg-p (form syntax) "Check whether `form' is a direct argument to one of its @@ -3689,10 +3692,11 @@ (multiple-value-list (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) (or (recurse (parent form)) - (unless (direct-arg-p form ,syntax-value-sym) + (unless (and (typep form 'complete-token-lexeme) + (direct-arg-p form ,syntax-value-sym)) form)))))) (or (recurse (parent immediate-form)) - immediate-form))))) + (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym)))

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25727 Modified Files: lisp-syntax.lisp Log Message: More work on arglist intelligence. I think it works now. Please report any breakage. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 09:09:43 1.92 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 11:35:28 1.93 @@ -3551,18 +3551,21 @@ (worker (parent operand-form))))))))) (nreverse (worker operand-form t))))) -(defun find-operand-info (mark syntax operator-form) - "Returns two values: The operand preceding `mark' and the path - from `operator-form' to the operand." - (let* ((preceding-arg-token (form-before syntax (offset mark))) +(defun find-operand-info (mark-or-offset syntax operator-form) + "Returns two values: The operand preceding `mark-or-offset' and + the path from `operator-form' to the operand." + (let* ((offset (if (numberp mark-or-offset) + mark-or-offset + (offset mark-or-offset))) + (preceding-arg-token (form-before syntax offset)) (indexing-start-arg (let* ((candidate-before preceding-arg-token) (candidate-after (when (null candidate-before) - (let ((after (form-after syntax (offset mark)))) + (let ((after (form-after syntax offset))) (when after (parent after))))) (candidate-around (when (null candidate-after) - (form-around syntax (offset mark)))) + (form-around syntax offset))) (candidate (or candidate-before candidate-after candidate-around))) @@ -3617,6 +3620,32 @@ (indices-match-arglist arg (rest arg-indices)) (null (rest arg-indices))))) +(defun direct-arg-p (form syntax) + "Check whether `form' is a direct argument to one of its + parents." + (labels ((recurse (parent) + (let ((operator (form-operator + parent + syntax))) + (or (and + ;; An operator is not an argument to itself... + (not (= (start-offset form) + (start-offset (first-form (children parent))))) + (valid-operator-p operator) + (indices-match-arglist + (arglist (image syntax) + operator) + (second + (multiple-value-list + (find-operand-info + (start-offset form) + syntax + parent))))) + (when (parent parent) + (recurse (parent parent))))))) + (when (parent form) + (recurse (parent form))))) + (defmacro with-code-insight (mark syntax (&key operator preceding-operand form preceding-operand-indices operands) @@ -3645,21 +3674,25 @@ ;; regard to the structure of the lambda list. If we ;; cannot find a form with a valid operator, just ;; return the form `mark' is in. - (labels ((recurse (form) - (if (and (valid-operator-p (form-operator - form - ,syntax-value-sym)) - (indices-match-arglist - (arglist (image syntax) - (form-operator - form - ,syntax-value-sym)) - (second (multiple-value-list (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) - (or (when (and form (parent form)) - (recurse (parent form))) - form)))) - (or (recurse (when immediate-form (parent immediate-form))) - (when immediate-form (parent immediate-form)))))) + (unless (null immediate-form) + (labels ((recurse (form) + (unless (null form) + (if (and (valid-operator-p (form-operator + form + ,syntax-value-sym)) + (indices-match-arglist + (arglist (image ,syntax-value-sym) + (form-operator + form + ,syntax-value-sym)) + (second + (multiple-value-list + (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) + (or (recurse (parent form)) + (unless (direct-arg-p form ,syntax-value-sym) + form)))))) + (or (recurse (parent immediate-form)) + immediate-form))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym)))

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7707 Modified Files: lisp-syntax.lisp Log Message: Climacs will now check whether the current argument indices are valid when figuring out which operator to display the arglist for. This permits more intelligent display of arglists. For example (with "|" being point): (with-output-to-string (list |) ) Previously, Swine (and SLIME for that matter) would display the arglist for `list', despite the fact that point is really in the arguments for `with-output-to-string'. It it still not perfect, this, for example, confuses it: (with-input-from-string (with-output-to-string (list |))) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 06:15:40 1.91 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 09:09:43 1.92 @@ -3137,6 +3137,10 @@ (defparameter +cl-garbage-keywords+ '(&whole &environment)) +(defun arglist-keyword-p (arg) + "Return T if `arg' is an arglist keyword. NIL otherwise." + (member arg +cl-arglist-keywords+)) + (defun split-arglist-on-keywords (arglist) "Return an alist keying lambda list keywords of `arglist' to the symbols affected by the keywords." @@ -3149,7 +3153,7 @@ (push (subseq arglist 0 2) sing-result) (setf arglist (cddr arglist))) (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body)) - (args (if (member (first arglist) +cl-arglist-keywords+) + (args (if (arglist-keyword-p (first arglist)) arglist (cons '&mandatory arglist)) (cdr args)) @@ -3597,6 +3601,22 @@ ((listp operator) (eq (first operator) 'cl:lambda)))) +(defun indices-match-arglist (arglist arg-indices) + "Check whether the argument indices `arg-indices' could refer + to a direct argument for the operator with the argument list + `arglist'. Returns T if they could, NIL otherwise. This + functions does not care about the argument quantity, only their + structure." + (let* ((index (first arg-indices)) + (pure-arglist (remove-if #'arglist-keyword-p arglist)) + (arg (when (< index (length pure-arglist)) + (elt pure-arglist index)))) + (if (and (not (null arg)) + (listp arg) + (rest arg-indices)) + (indices-match-arglist arg (rest arg-indices)) + (null (rest arg-indices))))) + (defmacro with-code-insight (mark syntax (&key operator preceding-operand form preceding-operand-indices operands) @@ -3609,7 +3629,7 @@ (operands-sym (or operands (gensym))) (form-sym (or form (gensym))) (operand-indices-sym (or preceding-operand-indices (gensym))) - ;; My kingdom for with-gensyms! + ;; My kingdom for with-gensyms (or once-only)! (mark-value-sym (gensym)) (syntax-value-sym (gensym))) `(let* ((,mark-value-sym ,mark) @@ -3626,12 +3646,18 @@ ;; cannot find a form with a valid operator, just ;; return the form `mark' is in. (labels ((recurse (form) - (if (valid-operator-p (form-operator - form - ,syntax-value-sym)) - form - (when (and form (parent form)) - (recurse (parent form)))))) + (if (and (valid-operator-p (form-operator + form + ,syntax-value-sym)) + (indices-match-arglist + (arglist (image syntax) + (form-operator + form + ,syntax-value-sym)) + (second (multiple-value-list (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) + (or (when (and form (parent form)) + (recurse (parent form))) + form)))) (or (recurse (when immediate-form (parent immediate-form))) (when immediate-form (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking @@ -3643,15 +3669,15 @@ ,@body)))) (defun show-arglist-for-form-at-mark (mark syntax) - "Display the argument list for the operator of `form'. The + "Display the argument list for the operator of `form'. The list need not be complete. If an argument list cannot be retrieved for the operator, nothing will be displayed." (with-code-insight mark syntax (:operator operator :preceding-operand preceding-operand :preceding-operand-indices preceding-operand-indices :operands operands) - (when (valid-operator-p operator) - (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))) + (when (valid-operator-p operator) + (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))) ;;; Definition editing

1 0

[climacs-cvs] CVS esa
by thenriksen 21 Jul '06

21 Jul '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29784 Modified Files: esa.lisp Log Message: `com-extended-command' should not be named. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/13 16:48:04 1.19 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/07/21 07:58:42 1.20 @@ -650,9 +650,6 @@ (set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) (define-command (com-extended-command - ;; FIXME: I don't think it makes any sense for - ;; Extended Command to be named. - :name t :command-table global-esa-table) () "Prompt for a command name and arguments, then run it." @@ -953,6 +950,7 @@ 'command-table :stream stream) (princ "an unknown command table" stream)) + (format stream ".~%") (when (plusp (length keystrokes)) (princ "It is bound to " stream)

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17972 Modified Files: pane.lisp gui.lisp Log Message: Changed `with-undo' so undo works properly for commands that modify buffers that were not the current buffer when the command loop started. A single undo operation still cannot undo for multiple buffers, however, so the user will have to manually invoke undo for each buffer. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/06 17:31:50 1.44 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/21 06:25:45 1.45 @@ -103,20 +103,28 @@ :objects (buffer-sequence buffer offset (+ offset n))) (undo-accumulate buffer)))) -(defmacro with-undo ((buffer) &body body) - (let ((buffer-var (gensym))) - `(let ((,buffer-var ,buffer)) - (setf (undo-accumulate ,buffer-var) '()) - (unwind-protect (progn ,@body) - (cond ((null (undo-accumulate ,buffer-var)) nil) - ((null (cdr (undo-accumulate ,buffer-var))) - (add-undo (car (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var))) - (t - (add-undo (make-instance 'compound-record - :buffer ,buffer-var - :records (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var)))))))) +(defmacro with-undo ((get-buffers-exp) &body body) + "Evaluate `body', registering any changes to buffer contents in +the undo memory for the respective buffer, permitting individual +undo for each buffer. `get-buffers-exp' should be a form, that +will be evaluated whenever a complete list of buffers is +needed (to set up all buffers to prepare for undo, and to check +them all for changes after `body' has run)." + (let ((buffer-sym (gensym))) + `(progn + (dolist (,buffer-sym ,get-buffers-exp) + (setf (undo-accumulate ,buffer-sym) '())) + (unwind-protect (progn ,@body) + (dolist (,buffer-sym ,get-buffers-exp) + (cond ((null (undo-accumulate ,buffer-sym)) nil) + ((null (cdr (undo-accumulate ,buffer-sym))) + (add-undo (car (undo-accumulate ,buffer-sym)) + (undo-tree ,buffer-sym))) + (t + (add-undo (make-instance 'compound-record + :buffer ,buffer-sym + :records (undo-accumulate ,buffer-sym)) + (undo-tree ,buffer-sym))))))))) (defmethod flip-undo-record :around ((record climacs-undo-record)) (with-slots (buffer) record --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/11 14:20:20 1.220 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/21 06:25:45 1.221 @@ -299,7 +299,7 @@ (handler-case (progn (if (buffer-pane-p current-window) - (with-undo ((buffer current-window)) + (with-undo ((buffers frame)) (call-next-method)) (call-next-method)) (loop for buffer in (buffers frame)

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11851 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Fixed issue where the symbol-completer was a bit too eager in deleting the original partial symbol. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/11 20:55:08 1.90 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 06:15:40 1.91 @@ -1575,6 +1575,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Useful functions for modifying forms based on the mark. + +(defun replace-symbol-at-mark (mark syntax string) + "Replace the symbol at `mark' with `string' and move `mark' to +after `string'." + (let ((token (symbol-at-mark mark syntax))) + (unless (= (offset mark) (start-offset token)) + (backward-expression mark syntax 1 nil)) + (forward-kill-expression mark syntax) + (insert-sequence mark string))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; display (defvar *white-space-start* nil) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/09 18:44:50 1.8 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/21 06:15:40 1.9 @@ -245,24 +245,22 @@ (clear-completions))) (define-command (com-complete-symbol :name t :command-table lisp-table) () - "Attempt to complete the symbol at mark. + "Attempt to complete the symbol at mark. If successful, move point +to end of symbol. -If more than one completion is available, a list of possible -completions will be displayed." +If more than one completion is available, a list of +possible completions will be displayed." (let* ((pane (current-window)) (buffer (buffer pane)) (syntax (syntax buffer)) - (point-current-window (point pane)) - (name (symbol-name-at-mark point-current-window + (mark (point pane)) + (name (symbol-name-at-mark mark syntax))) (when name - (with-syntax-package syntax point-current-window (package) - (let ((completion (show-completions syntax name package)) - (mark (clone-mark point-current-window))) + (with-syntax-package syntax mark (package) + (let ((completion (show-completions syntax name package))) (unless (= (length completion) 0) - (backward-object mark (length name)) - (delete-region mark point-current-window) - (insert-sequence point-current-window completion))))))) + (replace-symbol-at-mark mark syntax completion))))))) (define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () "Attempt to fuzzily complete the abbreviation at mark. @@ -273,17 +271,14 @@ (let* ((pane (current-window)) (buffer (buffer pane)) (syntax (syntax buffer)) - (point-current-window (point pane)) - (name (symbol-name-at-mark point-current-window + (mark (mark pane)) + (name (symbol-name-at-mark mark syntax))) (when name - (with-syntax-package syntax point-current-window (package) - (let ((completion (show-fuzzy-completions syntax name package)) - (mark (clone-mark point-current-window))) + (with-syntax-package syntax mark (package) + (let ((completion (show-fuzzy-completions syntax name package))) (unless (= (length completion) 0) - (backward-object mark (length name)) - (delete-region mark point-current-window) - (insert-sequence point-current-window completion))))))) + (replace-symbol-at-mark mark syntax completion))))))) (define-presentation-to-command-translator lookup-symbol-arglist (symbol com-lookup-arglist lisp-table

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7710 Modified Files: editing.lisp Log Message: Explicitly use the `stream-default-view' function in the CLIM package. This fix is indicative of a larger problem. --- /project/climacs/cvsroot/climacs/editing.lisp 2006/07/07 23:59:38 1.2 +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/21 05:08:26 1.3 @@ -303,7 +303,7 @@ "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `pane'." (let* ((buffer (buffer pane)) - (view (stream-default-view pane)) + (view (clim:stream-default-view pane)) (tab-space-count (tab-space-count view)) (tab-width (and (indent-tabs-mode buffer) tab-space-count))

1 0

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

20 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv32749 Removed Files: undo.html undo-en.html skeleton.html skeleton-en.html redisplay.html redisplay-en.html pdp.html index.html climacs.html climacs-en.html buffer.html buffer-en.html Log Message: Removed a bunch of no longer needed and possibly outdated HTML files.

1 0

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

11 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv30459 Modified Files: lisp-syntax.lisp Log Message: Added indentation rule for readtime-evaluation-forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/05 13:52:17 1.89 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/11 20:55:08 1.90 @@ -2438,6 +2438,11 @@ ((null (cdr path)) (values (first-form (children tree)) 0)))) +(defmethod indent-form ((syntax lisp-syntax) (tree readtime-evaluation-form) path) + (if (null (cdr path)) + (values tree 0) + (indent-form syntax (elt-form (children tree) 0) (cdr path)))) + (defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) (if (= (car path) 1) ;; before first element

1 0

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

11 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7651 Modified Files: packages.lisp gui.lisp climacs.asd Added Files: climacs.lisp Log Message: Added new CLIMACS package and moved entry points to it. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/09 18:44:50 1.103 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/11 14:20:20 1.104 @@ -4,6 +4,8 @@ ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.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 @@ -22,6 +24,8 @@ ;;; Package definitions for the Climacs editor. +(in-package :cl-user) + (defpackage :climacs-buffer (:use :clim-lisp :flexichain :binseq) (:export #:buffer #:standard-buffer @@ -318,33 +322,41 @@ :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa :climacs-editing :climacs-motion) ;;(:import-from :lisp-string) - (:export :climacs ; Main entry point. + (:export #:climacs ; Frame. + ;; GUI functions follow. - :climacs-rv ; Entry point with alternate colors. - :current-window - :current-point - :current-buffer - :current-buffer - :point - :syntax - :mark - :insert-character - :base-table - :buffer-table - :case-table - :comment-table - :deletion-table - :development-table - :editing-table - :fill-table - :indent-table - :info-table - :marking-table - :movement-table - :pane-table - :search-table - :self-insert-table - :window-table)) + #:current-window + #:current-point + #:current-buffer + #:current-buffer + #:point + #:syntax + #:mark + #:insert-character + #:base-table + #:buffer-table + #:case-table + #:comment-table + #:deletion-table + #:development-table + #:editing-table + #:fill-table + #:indent-table + #:info-table + #:marking-table + #:movement-table + #:pane-table + #:search-table + #:self-insert-table + #:window-table + + ;; Some configuration variables + #:*bg-color* + #:*fg-color* + #:*info-bg-color* + #:*info-fg-color* + #:*mini-bg-color* + #:*mini-fg-color*)) (defpackage :climacs-commands (:use :clim-lisp :clim :climacs-base :climacs-buffer @@ -379,4 +391,12 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing) - (:export :lisp-string)) \ No newline at end of file + (:export #:lisp-string + #:edit-definition)) + +(defpackage :climacs + (:use :clim-lisp :clim :clim-sys :clim-extensions :climacs-gui) + (:export #:climacs + #:climacs-rv + #:edit-definition) + (:documentation "Package containing entry points to Climacs.")) \ No newline at end of file --- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/13 11:34:52 1.219 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/11 14:20:20 1.220 @@ -201,33 +201,6 @@ "Return the current buffer." (buffer (current-window))) -(defun climacs (&key new-process (process-name "Climacs") - (width 900) (height 400)) - "Starts up a climacs session" - (let ((frame (make-application-frame 'climacs :width width :height height))) - (flet ((run () - (run-frame-top-level frame))) - (if new-process - (clim-sys:make-process #'run :name process-name) - (run))))) - -(defun climacs-rv (&key new-process (process-name "Climacs") - (width 900) (height 400)) - "Starts up a climacs session" - ;; SBCL doesn't inherit dynamic bindings when starting new - ;; processes, so start a new processes and THEN setup the colors. - (flet ((run () - (let ((*bg-color* +black+) - (*fg-color* +gray+) - (*info-bg-color* +darkslategray+) - (*info-fg-color* +gray+) - (*mini-bg-color* +black+) - (*mini-fg-color* +white+)) - (climacs :new-process nil :width width :height height)))) - (if new-process - (clim-sys:make-process #'run :name process-name) - (run)))) - (define-presentation-type read-only ()) (define-presentation-method highlight-presentation ((type read-only) record stream state) @@ -540,25 +513,6 @@ 'pane-table '((#\x :control) (#\k))) -#+sbcl -(defun ed-in-climacs (thing) - (let ((frame-manager (find-frame-manager))) - (when frame-manager - (let ((climacs-frame (find-if (lambda (x) (typep x 'climacs)) - (frame-manager-frames frame-manager)))) - (when climacs-frame - (typecase thing - ((or pathname string) - (execute-frame-command - climacs-frame `(com-find-file ,(pathname thing))) - t) - ((or symbol cons) - ;; FIXME: do something - nil))))))) - -#+sbcl -(pushnew 'ed-in-climacs sb-ext:*ed-functions*) - ;;; For the ESA help functions. (defmethod help-stream ((frame climacs) title) --- /project/climacs/cvsroot/climacs/climacs.lisp 2004/12/16 06:23:42 1.2 +++ /project/climacs/cvsroot/climacs/climacs.lisp 2006/07/11 14:20:20 1.3 @@ -1,145 +1,58 @@ -(defpackage :climacs - (:use :clim-lisp :clim :climacs-buffer)) +;;; -*- Mode: Lisp; Package: CLIMACS -*- -(in-package :climacs) - -(define-application-frame climacs () - ((buffer :initform (make-instance 'standard-buffer) - :accessor buffer) - (point :initform nil :reader point)) - (:panes - (win :interactor :width 600 :height 200 - :display-function 'display-win)) - (:layouts - (default (vertically () win))) - (:top-level (climacs-top-level))) - -(defmethod initialize-instance :after ((frame climacs) &rest args) - (declare (ignore args)) - (setf (slot-value frame 'point) - (make-instance 'standard-right-sticky-mark - :buffer (buffer frame)))) - -(defun climacs () - (run-frame-top-level (make-application-frame 'climacs))) - -(defun display-win (frame pane) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium)) - (height (* 1.1 (text-style-height style medium))) - (width (text-style-width style medium))) - (loop with size = (size (buffer frame)) - with y = height - for x from 0 by width - for offset from 0 below size - do (if (char= (buffer-char (buffer frame) offset) #\Newline) - (setf y (+ y height) - x (- width)) - (draw-text* pane (buffer-char (buffer frame) offset) x y))) - (let* ((line (line-number (point frame))) - (col (column-number (point frame))) - (x (* width col)) - (y (* height (+ line 0.5)))) - (draw-line* pane x (- y (* 0.5 height)) x (+ y (* 0.5 height)) :ink +red+)))) - -(defun find-gestures (gestures start-table) - (loop with table = (find-command-table start-table) - for (gesture . rest) on gestures - for item = (find-keystroke-item gesture table :errorp nil) - while item - do (if (eq (command-menu-item-type item) :command) - (return (if (null rest) item nil)) - (setf table (command-menu-item-value item))) - finally (return item))) - -(defparameter *current-gesture* nil) - -(defun climacs-top-level (frame &key - command-parser command-unparser - partial-command-parser prompt) - (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (let ((*standard-output* (frame-standard-output frame)) - (*standard-input* (frame-standard-input frame)) - (*print-pretty* nil)) - (redisplay-frame-panes frame :force-p t) - (loop with gestures = '() - do (setf *current-gesture* (read-gesture :stream *standard-input*)) - (when (or (characterp *current-gesture*) - (keyboard-event-character *current-gesture*)) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (setf gestures '())) - ((eq (command-menu-item-type item) :command) - (funcall (command-menu-item-value item)) - (setf gestures '())) - (t nil)))) - (redisplay-frame-panes frame :force-p t)))) - -(define-command com-quit () - (frame-exit *application-frame*)) - -(define-command com-self-insert () - (insert-text (point *application-frame*) *current-gesture*)) - -(define-command com-backward-char () - (decf (offset (point *application-frame*)))) - -(define-command com-forward-char () - (incf (offset (point *application-frame*)))) - -(define-command com-beginning-of-line () - (beginning-of-line (point *application-frame*))) - -(define-command com-end-of-line () - (end-of-line (point *application-frame*))) - -(define-command com-delete-char () - (delete-text (point *application-frame*))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Global command table - -(make-command-table 'global-climacs-table :errorp nil) - -(loop for code from (char-code #\space) to (char-code #\~) - do (add-command-to-command-table - 'com-self-insert - (find-command-table 'global-climacs-table) - :keystroke (code-char code) :errorp nil)) - -(add-command-to-command-table 'com-self-insert (find-command-table 'global-climacs-table) - :keystroke #\newline :errorp nil) - -(add-command-to-command-table 'com-forward-char (find-command-table 'global-climacs-table) - :keystroke '(#\f :control) :errorp nil) - -(add-command-to-command-table 'com-backward-char (find-command-table 'global-climacs-table) - :keystroke '(#\b :control) :errorp nil) - -(add-command-to-command-table 'com-beginning-of-line (find-command-table 'global-climacs-table) - :keystroke '(#\a :control) :errorp nil) - -(add-command-to-command-table 'com-end-of-line (find-command-table 'global-climacs-table) - :keystroke '(#\e :control) :errorp nil) - -(add-command-to-command-table 'com-delete-char (find-command-table 'global-climacs-table) - :keystroke '(#\d :control) :errorp nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; C-x command table - -(make-command-table 'c-x-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "C-x" - :menu (find-command-table 'c-x-climacs-table) - :keystroke '(#\x :control)) +;;; (c) copyright 2004-2005 by +;;; Robert Strandh (strandh(a)labri.fr) +;;; (c) copyright 2004-2005 by +;;; Elliott Johnson (ejohnson(a)fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) +;;; (c) copyright 2005 by +;;; Aleksandar Bakic (a_bakic(a)yahoo.com) +;;; (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 +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. -;;; for some reason, C-c does not seem to arrive as far as CLIM. - -(add-command-to-command-table 'com-quit (find-command-table 'c-x-climacs-table) - :keystroke '(#\q :control)) +;;; Entry points for the Climacs editor. +(in-package :climacs) +(defun climacs (&key new-process (process-name "Climacs") + (width 900) (height 400)) + "Starts up a climacs session" + (let ((frame (make-application-frame 'climacs :width width :height height))) + (flet ((run () + (run-frame-top-level frame))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run))))) + +(defun climacs-rv (&key new-process (process-name "Climacs") + (width 900) (height 400)) + "Starts up a climacs session with alternative colors." + ;; SBCL doesn't inherit dynamic bindings when starting new + ;; processes, so start a new processes and THEN setup the colors. + (flet ((run () + (let ((*bg-color* +black+) + (*fg-color* +gray+) + (*info-bg-color* +darkslategray+) + (*info-fg-color* +gray+) + (*mini-bg-color* +black+) + (*mini-fg-color* +white+)) + (climacs :new-process nil :width width :height height)))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run)))) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/05 13:52:17 1.46 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/11 14:20:20 1.47 @@ -2,6 +2,8 @@ ;;; (c) copyright 2004 by ;;; Robert Strandh (strandh(a)labri.u-bordeaux.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 @@ -91,6 +93,7 @@ (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" "abbrev" "editing" "motion")) + (:file "climacs" :depends-on ("gui")) ;; (:file "buffer-commands" :depends-on ("gui")) (:file "developer-commands" :depends-on ("gui" "lisp-syntax")) (:file "motion-commands" :depends-on ("gui"))

1 0

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

09 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12893 Modified Files: packages.lisp motion-commands.lisp lisp-syntax-commands.lisp editing-commands.lisp Log Message: Unified CLIMACS-MOTION-COMMANDS and CLIMACS-EDITING-COMMANDS into a CLIMACS-COMMANDS package, added documentation strings to some package definitions to make it more clear what they (are supposed to) contain. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/07 23:59:38 1.102 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/09 18:44:50 1.103 @@ -54,7 +54,10 @@ #:persistent-left-sticky-mark #:persistent-right-sticky-mark #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark #:p-line-mark-mixin #:buffer-line-offset - #:delegating-buffer #:implementation)) + #:delegating-buffer #:implementation) + (:documentation "An implementation of the Climacs buffer + protocol. This package is quite low-level, not syntax-aware, + not CLIM-aware and not user-oriented at all.")) (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) @@ -63,7 +66,8 @@ #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push - #:kill-ring-reverse-concatenating-push)) + #:kill-ring-reverse-concatenating-push) + (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base (:use :clim-lisp :climacs-buffer :climacs-kill-ring) @@ -93,7 +97,15 @@ #:capitalize-buffer-region #:capitalize-region #:tabify-region #:untabify-region #:indent-line #:delete-indentation - #:*kill-ring*)) + #:*kill-ring*) + (:documentation "Basic functionality built on top of the buffer + protocol. Here is where we define slightly higher level + functions, that can be directly implemented in terms of the + buffer protocol, but that are not, strictly speaking, part of + that protocol. The functions in this package are not + syntax-aware, and are thus limited in what they can do. They + percieve the buffer as little more than a sequence of + characters.")) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -138,10 +150,13 @@ #:word-constituentp #:whitespacep #:page-delimiter - #:paragraph-delimiter)) + #:paragraph-delimiter) + (:documentation "The Climacs syntax protocol. Contains + functions that can be used to implement higher-level operations + on buffer contents.")) (defpackage :undo - (:use :common-lisp) + (:use :clim-lisp) (:export #:no-more-undo #:undo-tree #:standard-undo-tree #:undo-record #:standard-undo-record @@ -174,7 +189,7 @@ #:climacs-textual-view #:+climacs-textual-view+)) (defpackage :climacs-motion - (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax) + (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax) (:export #:forward-to-word-boundary #:backward-to-word-boundary #:define-motion-fns #:beep-limit-action #:revert-limit-action #:error-limit-action @@ -233,10 +248,16 @@ #:forward-one-sentence #:backward-one-sentence #:forward-sentence - #:backward-sentence)) + #:backward-sentence) + (:documentation "Functions and facilities for moving a mark + around by syntactical elements. The functions in this package + are syntax-aware, and their behavior is based on the semantics + defined by the syntax of the buffer, that the mark they are + manipulating belong to. These functions are also directly used + to implement the motion commands.")) (defpackage :climacs-editing - (:use :clim-lisp :clim :climacs-base :climacs-buffer + (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring) (:export #:transpose-objects @@ -283,7 +304,13 @@ #:indent-region #:fill-line - #:fill-region)) + #:fill-region) + (:documentation "Functions and facilities for changing the + buffer contents by syntactical elements. The functions in this package + are syntax-aware, and their behavior is based on the semantics + defined by the syntax of the buffer, that the mark they are + manipulating belong to. These functions are also directly used + to implement the editing commands.")) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base @@ -319,17 +346,16 @@ :self-insert-table :window-table)) -(defpackage :climacs-motion-commands - (:use :clim-lisp :clim :climacs-base :climacs-buffer - :climacs-syntax :climacs-motion :climacs-gui :esa) - (:export #:define-motion-commands)) - -(defpackage :climacs-editing-commands +(defpackage :climacs-commands (:use :clim-lisp :clim :climacs-base :climacs-buffer - :climacs-syntax :climacs-motion :climacs-gui - :esa :climacs-editing :climacs-kill-ring) - (:export #:define-deletion-commands - #:define-editing-commands)) + :climacs-syntax :climacs-motion :climacs-editing + :climacs-gui :esa :climacs-kill-ring) + (:export #:define-motion-commands + #:define-deletion-commands + #:define-editing-commands) + (:documentation "This package is meant to contain Climacs' + command definitions, as well as some useful automatic + command-defining facilities.")) (defpackage :climacs-fundamental-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base --- /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/07/09 18:44:50 1.2 @@ -42,7 +42,7 @@ ;;; forward by N <plural>.' ;;; -(in-package :climacs-motion-commands) +(in-package :climacs-commands) (defmacro define-motion-commands (unit command-table &key noun --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/05 13:52:17 1.7 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/09 18:44:50 1.8 @@ -31,18 +31,18 @@ (in-package :climacs-lisp-syntax) ;; Movement commands. -(climacs-motion-commands:define-motion-commands expression lisp-table) -(climacs-motion-commands:define-motion-commands definition lisp-table) -(climacs-motion-commands:define-motion-commands up lisp-table +(climacs-commands:define-motion-commands expression lisp-table) +(climacs-commands:define-motion-commands definition lisp-table) +(climacs-commands:define-motion-commands up lisp-table :noun "nesting level up" :plural "levels") -(climacs-motion-commands:define-motion-commands down lisp-table +(climacs-commands:define-motion-commands down lisp-table :noun "nesting level down" :plural "levels") -(climacs-motion-commands:define-motion-commands list lisp-table) +(climacs-commands:define-motion-commands list lisp-table) -(climacs-editing-commands:define-editing-commands expression lisp-table) -(climacs-editing-commands:define-deletion-commands expression lisp-table) +(climacs-commands:define-editing-commands expression lisp-table) +(climacs-commands:define-deletion-commands expression lisp-table) (define-command (com-eval-defun :name t :command-table lisp-table) () (let* ((pane (current-window)) --- /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/07/02 15:43:48 1.2 +++ /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/07/09 18:44:50 1.3 @@ -43,7 +43,7 @@ ;;; This file also holds command definitions for other functions ;;; defined in the CLIMACS-EDITING package. -(in-package :climacs-editing-commands) +(in-package :climacs-commands) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

08 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12036 Modified Files: buffer-test.lisp base-test.lisp Log Message: Updated the unit tests to be valid again, commented out a few tests that are based on now-invalid assumptions. These will become part of a new set of tests once I have time. --- /project/climacs/cvsroot/climacs/buffer-test.lisp 2005/08/04 22:07:44 1.21 +++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/08 00:11:22 1.22 @@ -4,7 +4,7 @@ ;;; (cl:defpackage :climacs-tests - (:use :cl :rtest :climacs-buffer :climacs-base :automaton)) + (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion :climacs-editing :automaton)) (cl:in-package :climacs-tests) @@ -1055,7 +1055,7 @@ for i from 0 below 1000 for f = t then (not b) do (if f - (next-line m 0 100000) + (forward-line m 0 100000) (previous-line m 0 100000)) finally (return (number-of-lines b)))))) 100000) \ No newline at end of file --- /project/climacs/cvsroot/climacs/base-test.lisp 2005/08/27 22:07:45 1.16 +++ /project/climacs/cvsroot/climacs/base-test.lisp 2006/07/08 00:11:22 1.17 @@ -190,59 +190,59 @@ "climacs " 7) -(defmultitest kill-line.test-1 +(defmultitest delete-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :left))) (setf (offset mark) 0) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) #() 0) -(defmultitest kill-line.test-2 +(defmultitest delete-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :right))) (setf (offset mark) 0) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) #() 0) -(defmultitest kill-line.test-3 +(defmultitest delete-line.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :left))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs" 7) -(defmultitest kill-line.test-4 +(defmultitest delete-line.test-4 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :right))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs" 7) -(defmultitest kill-line.test-5 +(defmultitest delete-line.test-5 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (clone-mark (low-mark buffer) :left))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacsclimacs" 7) -(defmultitest kill-line.test-6 +(defmultitest delete-line.test-6 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (clone-mark (low-mark buffer) :right))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacsclimacs" 7) @@ -459,16 +459,19 @@ (constituentp #\Null)) t nil nil nil nil #-sbcl nil #+sbcl t) -(defmultitest whitespacep.test-1 +(defmultitest buffer-whitespacep.test-1 (values - (not (null (whitespacep #\a))) - (not (null (whitespacep #\Newline))) - (not (null (whitespacep #\Space))) - (not (null (whitespacep #\Tab))) - (not (null (whitespacep " "))) - (not (null (whitespacep #\Null)))) + (not (null (buffer-whitespacep #\a))) + (not (null (buffer-whitespacep #\Newline))) + (not (null (buffer-whitespacep #\Space))) + (not (null (buffer-whitespacep #\Tab))) + (not (null (buffer-whitespacep " "))) + (not (null (buffer-whitespacep #\Null)))) nil t t t nil nil) +;; Words are not recognized by CLIMACS-BASE, setup syntax-aware +;; tests. Until then, these are disabled. +#|| (defmultitest forward-to-word-boundary.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs @@ -627,6 +630,7 @@ (climacs-base::previous-word m1) (climacs-base::previous-word m2)))) "climacs" #() "cl") +||# (defmultitest downcase-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -664,16 +668,16 @@ (buffer-sequence buffer 0 (size buffer)))) "_cli mac5_") -(defmultitest downcase-word.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 0) - (downcase-word m 3) - (values - (buffer-sequence buffer 0 (size buffer)) - (offset m)))) - "cli ma cs CLIMACS" 9) +#+(or)(defmultitest downcase-word.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) + (downcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli ma cs CLIMACS" 9) (defmultitest upcase-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -711,16 +715,16 @@ (buffer-sequence buffer 0 (size buffer)))) "_CLI MAC5_") -(defmultitest upcase-word.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs climacs") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 0) - (upcase-word m 3) - (values - (buffer-sequence buffer 0 (size buffer)) - (offset m)))) - "CLI MA CS climacs" 9) +#+(or)(defmultitest upcase-word.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) + (upcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "CLI MA CS climacs" 9) (defmultitest capitalize-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -765,16 +769,16 @@ (buffer-sequence buffer 0 (size buffer)))) "_Cli Mac5_") -(defmultitest capitalize-word.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs climacs") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 0) - (capitalize-word m 3) - (values - (buffer-sequence buffer 0 (size buffer)) - (offset m)))) - "Cli Ma Cs climacs" 9) +#+(or)(defmultitest capitalize-word.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) + (capitalize-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "Cli Ma Cs climacs" 9) (defmultitest tabify-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -960,7 +964,7 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 25) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 t) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -973,7 +977,7 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 25) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 nil) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 t nil) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -986,7 +990,7 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) 25) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 t) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -1012,7 +1016,7 @@ (insert-buffer-sequence buffer 0 "c l i m a c s") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 1) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 t) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -1023,7 +1027,7 @@ (insert-buffer-sequence buffer 0 "c l i m a c s") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 1) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 nil) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 t nil) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -1253,26 +1257,26 @@ (offset m))) 3) -(defmultitest buffer-search-word-forward.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " +#+(or)(defmultitest buffer-search-word-forward.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 " climacs") - (values - (climacs-base::buffer-search-word-forward buffer 0 "climacs") - (climacs-base::buffer-search-word-forward buffer 3 "climacs") - (climacs-base::buffer-search-word-forward buffer 0 "clim") - (climacs-base::buffer-search-word-forward buffer 5 "macs") - (climacs-base::buffer-search-word-forward buffer 0 ""))) - 2 nil nil nil 0) - -(defmultitest buffer-search-word-backward.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "climacs + (values + (climacs-base::buffer-search-word-forward buffer 0 "climacs") + (climacs-base::buffer-search-word-forward buffer 3 "climacs") + (climacs-base::buffer-search-word-forward buffer 0 "clim") + (climacs-base::buffer-search-word-forward buffer 5 "macs") + (climacs-base::buffer-search-word-forward buffer 0 ""))) + 2 nil nil nil 0) + +#+(or)(defmultitest buffer-search-word-backward.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs ") - (values - (climacs-base::buffer-search-word-backward buffer 8 "climacs") - (climacs-base::buffer-search-word-backward buffer 5 "climacs") - (climacs-base::buffer-search-word-backward buffer 4 "clim") - (climacs-base::buffer-search-word-backward buffer 8 "macs") - (climacs-base::buffer-search-word-backward buffer 8 ""))) - 0 nil nil nil 8) \ No newline at end of file + (values + (climacs-base::buffer-search-word-backward buffer 8 "climacs") + (climacs-base::buffer-search-word-backward buffer 5 "climacs") + (climacs-base::buffer-search-word-backward buffer 4 "clim") + (climacs-base::buffer-search-word-backward buffer 8 "macs") + (climacs-base::buffer-search-word-backward buffer 8 ""))) + 0 nil nil nil 8) \ No newline at end of file

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv10216 Modified Files: packages.lisp editing.lisp base.lisp Log Message: A number of major changes, involving moving a bit of stuff back from editing.lisp (and CLIMACS EDITING) to base.lisp (and CLIMACS-BASE). * Reintroduced primitive, non-syntax-aware `previous-line' and `next-line' generic functions. * Moved `open-line' back to base.lisp and added a primitive `delete-line' function for deleting lines at a given mark. * Moved most of the character casing, tabyfying and indentation code back from editing.lisp to base.lisp. I'm still not sure it belongs there, but it will have to do for now. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/03 15:46:53 1.101 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/07 23:59:38 1.102 @@ -70,12 +70,15 @@ (:export #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line + #:open-line + #:delete-line #:empty-line-p #:line-indentation #:buffer-display-column #:number-of-lines-in-region #:constituentp #:just-n-spaces + #:buffer-whitespacep #:forward-word #:backward-word #:buffer-region-case #:input-from-stream #:output-to-stream @@ -85,6 +88,11 @@ #:buffer-re-search-forward #:buffer-re-search-backward #:search-forward #:search-backward #:re-search-forward #:re-search-backward + #:downcase-buffer-region #:downcase-region + #:upcase-buffer-region #:upcase-region + #:capitalize-buffer-region #:capitalize-region + #:tabify-region #:untabify-region + #:indent-line #:delete-indentation #:*kill-ring*)) (defpackage :climacs-abbrev @@ -231,7 +239,6 @@ (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring) (:export #:transpose-objects - #:open-line ;; Lines #:forward-delete-line #:backward-delete-line @@ -271,15 +278,10 @@ #:forward-kill-sentence #:backward-kill-sentence #:transpose-sentences - #:downcase-buffer-region #:downcase-region - #:upcase-buffer-region #:upcase-region - #:downcase-word #:upcase-word - #:capitalize-buffer-region #:capitalize-region - #:capitalize-word - #:tabify-region #:untabify-region - #:indent-line + + #:downcase-word #:upcase-word #:capitalize-word + #:indent-region - #:delete-indentation #:fill-line #:fill-region)) --- /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/07 23:59:38 1.2 @@ -211,17 +211,6 @@ ;;; ;;; Line editing -(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline))) - -(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline) - (decf (offset mark)))) - (define-edit-fns line) (define-edit-fns line-start) @@ -280,38 +269,6 @@ ;;; ;;; Character case -;;; I'd rather have update-buffer-range methods spec. on buffer for this, -;;; for performance and history-size reasons --amb -(defun downcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (upper-case-p object)) - (setf object (char-downcase object))))) - -(defgeneric downcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -lowercase. 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.")) - -(defmethod downcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod downcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod downcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - (defun downcase-word (mark &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) @@ -321,36 +278,6 @@ (forward-word mark syntax 1 nil) (downcase-region offset mark))))) -(defun upcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (lower-case-p object)) - (setf object (char-upcase object))))) - -(defgeneric upcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -uppercase. 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.")) - -(defmethod upcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod upcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod upcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - (defun upcase-word (mark syntax &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." (loop repeat n @@ -359,42 +286,6 @@ (forward-word mark syntax 1 nil) (upcase-region offset mark)))) -(defun capitalize-buffer-region (buffer offset1 offset2) - (let ((previous-char-constituent-p nil)) - (do-buffer-region (object offset buffer offset1 offset2) - (when (constituentp object) - (if previous-char-constituent-p - (when (upper-case-p object) - (setf object (char-downcase object))) - (when (lower-case-p object) - (setf object (char-upcase object))))) - (setf previous-char-constituent-p (constituentp object))))) - -(defgeneric capitalize-region (mark1 mark2) - (:documentation "Capitalize all words after mark1 and before 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.")) - -(defmethod capitalize-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod capitalize-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod capitalize-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - (defun capitalize-word (mark &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) @@ -406,134 +297,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Tabify - -(defun tabify-buffer-region (buffer offset1 offset2 tab-width) - (flet ((looking-at-spaces (buffer offset count) - (loop for i from offset - repeat count - unless (char= (buffer-object buffer i) #\Space) - return nil - finally (return t)))) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - do (let* ((column (buffer-display-column - buffer offset tab-width)) - (count (- tab-width (mod column tab-width)))) - (when (looking-at-spaces buffer offset count) - (finish-output) - (delete-buffer-range buffer offset count) - (insert-buffer-object buffer offset #\Tab) - (decf offset2 (1- count))))))) - -(defgeneric tabify-region (mark1 mark2 tab-width) - (:documentation "Replace sequences of tab-width spaces with tabs -in the region delimited by mark1 and mark2.")) - -(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defun untabify-buffer-region (buffer offset1 offset2 tab-width) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - when (char= (buffer-object buffer offset) #\Tab) - do (let* ((column (buffer-display-column buffer - offset - tab-width)) - (count (- tab-width (mod column tab-width)))) - (delete-buffer-range buffer offset 1) - (loop repeat count - do (insert-buffer-object buffer offset #\Space)) - (incf offset (1- count)) - (incf offset2 (1- count))))) - -(defgeneric untabify-region (mark1 mark2 tab-width) - (:documentation "Replace tabs with tab-width spaces in the region -delimited by mark1 and mark2.")) - -(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Indentation -(defgeneric indent-line (mark indentation tab-width) - (:documentation "Indent the line containing mark with indentation -spaces. Use tabs and spaces if tab-width is not nil, otherwise use -spaces only.")) - -(defun indent-line* (mark indentation tab-width left) - (let ((mark2 (clone-mark mark))) - (beginning-of-line mark2) - (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (delete-range mark2 1)) - (loop until (zerop indentation) - do (cond ((and tab-width (>= indentation tab-width)) - (insert-object mark2 #\Tab) - (when left ; spaces must follow tabs - (forward-object mark2)) - (decf indentation tab-width)) - (t - (insert-object mark2 #\Space) - (decf indentation)))))) - -(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width t)) - -(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width nil)) - -(defun delete-indentation (mark syntax) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (whitespacep syntax (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (whitespacep syntax (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) - (defun indent-region (pane mark1 mark2) "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `pane'." --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/03 15:46:53 1.53 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/07 23:59:38 1.54 @@ -63,6 +63,81 @@ (unless (end-of-buffer-p ,mark-sym) (forward-object ,mark-sym))))))) +(defgeneric previous-line (mark &optional column count) + (:documentation "Move a mark up `count' lines conserving + horizontal position. This is a relatively low-level function, + you should probably use `climacs-motion:backward-line' + instead.")) + +(defmethod previous-line (mark &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (loop repeat count + do (beginning-of-line mark) + until (beginning-of-buffer-p mark) + do (backward-object mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))) + +(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (max 0 (- line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + +(defgeneric next-line (mark &optional column count) + (:documentation "Move a mark down `count' lines conserving + horizontal position. This is a relatively low-level function, + you should probably use `climacs-motion:forward-line' + instead.")) + +(defmethod next-line (mark &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (loop repeat count + do (end-of-line mark) + until (end-of-buffer-p mark) + do (forward-object mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))) + +(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (min (number-of-lines (buffer mark)) + (+ line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + +(defgeneric open-line (mark &optional count) + (:documentation "Create a new line in a buffer after the mark.")) + +(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) + (loop repeat count + do (insert-object mark #\Newline))) + +(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) + (loop repeat count + do (insert-object mark #\Newline) + (decf (offset mark)))) + +(defun delete-line (mark &optional (count 1)) + "Delete `count' lines at `mark' from the buffer." + (dotimes (i count) + (if (end-of-line-p mark) + (unless (end-of-buffer-p mark) + (delete-range mark)) + (let ((offset (offset mark))) + (end-of-line mark) + (delete-region offset mark))))) + (defun empty-line-p (mark) "Check whether the mark is in an empty line." (and (beginning-of-line-p mark) (end-of-line-p mark))) @@ -381,6 +456,238 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Character case + +;;; I'd rather have update-buffer-range methods spec. on buffer for this, +;;; for performance and history-size reasons --amb +(defun downcase-buffer-region (buffer offset1 offset2) + (do-buffer-region (object offset buffer offset1 offset2) + (when (and (constituentp object) (upper-case-p object)) + (setf object (char-downcase object))))) + +(defgeneric downcase-region (mark1 mark2) + (:documentation "Convert all characters after mark1 and before mark2 to +lowercase. 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.")) + +(defmethod downcase-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod downcase-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod downcase-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark1) offset1 offset2))) + +(defun upcase-buffer-region (buffer offset1 offset2) + (do-buffer-region (object offset buffer offset1 offset2) + (when (and (constituentp object) (lower-case-p object)) + (setf object (char-upcase object))))) + +(defgeneric upcase-region (mark1 mark2) + (:documentation "Convert all characters after mark1 and before mark2 to +uppercase. 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.")) + +(defmethod upcase-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod upcase-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod upcase-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark1) offset1 offset2))) + +(defun capitalize-buffer-region (buffer offset1 offset2) + (let ((previous-char-constituent-p nil)) + (do-buffer-region (object offset buffer offset1 offset2) + (when (constituentp object) + (if previous-char-constituent-p + (when (upper-case-p object) + (setf object (char-downcase object))) + (when (lower-case-p object) + (setf object (char-upcase object))))) + (setf previous-char-constituent-p (constituentp object))))) + +(defgeneric capitalize-region (mark1 mark2) + (:documentation "Capitalize all words after mark1 and before 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.")) + +(defmethod capitalize-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod capitalize-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod capitalize-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark1) offset1 offset2))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Tabify + +(defun tabify-buffer-region (buffer offset1 offset2 tab-width) + (flet ((looking-at-spaces (buffer offset count) + (loop for i from offset + repeat count + unless (char= (buffer-object buffer i) #\Space) + return nil + finally (return t)))) + (loop for offset = offset1 then (1+ offset) + until (>= offset offset2) + do (let* ((column (buffer-display-column + buffer offset tab-width)) + (count (- tab-width (mod column tab-width)))) + (when (looking-at-spaces buffer offset count) + (finish-output) + (delete-buffer-range buffer offset count) + (insert-buffer-object buffer offset #\Tab) + (decf offset2 (1- count))))))) + +(defgeneric tabify-region (mark1 mark2 tab-width) + (:documentation "Replace sequences of tab-width spaces with tabs +in the region delimited by mark1 and mark2.")) + +(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) + +(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +(defun untabify-buffer-region (buffer offset1 offset2 tab-width) + (loop for offset = offset1 then (1+ offset) + until (>= offset offset2) + when (char= (buffer-object buffer offset) #\Tab) + do (let* ((column (buffer-display-column buffer + offset + tab-width)) + (count (- tab-width (mod column tab-width)))) + (delete-buffer-range buffer offset 1) + (loop repeat count + do (insert-buffer-object buffer offset #\Space)) + (incf offset (1- count)) + (incf offset2 (1- count))))) + +(defgeneric untabify-region (mark1 mark2 tab-width) + (:documentation "Replace tabs with tab-width spaces in the region +delimited by mark1 and mark2.")) + +(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) + +(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Indentation + +(defgeneric indent-line (mark indentation tab-width) + (:documentation "Indent the line containing mark with indentation +spaces. Use tabs and spaces if tab-width is not nil, otherwise use +spaces only.")) + +(defun indent-line* (mark indentation tab-width left) + (let ((mark2 (clone-mark mark))) + (beginning-of-line mark2) + (loop until (end-of-buffer-p mark2) + as object = (object-after mark2) + while (or (eql object #\Space) (eql object #\Tab)) + do (delete-range mark2 1)) + (loop until (zerop indentation) + do (cond ((and tab-width (>= indentation tab-width)) + (insert-object mark2 #\Tab) + (when left ; spaces must follow tabs + (forward-object mark2)) + (decf indentation tab-width)) + (t + (insert-object mark2 #\Space) + (decf indentation)))))) + +(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) + (indent-line* mark indentation tab-width t)) + +(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) + (indent-line* mark indentation tab-width nil)) + +(defun delete-indentation (mark) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (delete-range mark -1) + (loop until (end-of-buffer-p mark) + while (buffer-whitespacep (object-after mark)) + do (delete-range mark 1)) + (loop until (beginning-of-buffer-p mark) + while (buffer-whitespacep (object-before mark)) + do (delete-range mark -1)) + (when (and (not (beginning-of-buffer-p mark)) + (constituentp (object-before mark))) + (insert-object mark #\Space)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Kill ring -(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) \ No newline at end of file +(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6679 Modified Files: syntax.lisp Log Message: Make `whitespacep' just return T on success. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/12 19:10:58 1.66 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/07/07 23:23:10 1.67 @@ -742,7 +742,8 @@ (:method (syntax obj) nil) (:method (syntax (obj character)) - (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) + (when (member obj '(#\Space #\Tab #\Newline #\Page #\Return)) + t))) (defgeneric page-delimiter (syntax) (:documentation "Return the object sequence used as a page

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17361 Removed Files: colors.lisp Log Message: Removed colors.lisp, it's in ESA now and no longer used in Climacs.

1 0

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

06 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5211 Modified Files: pane.lisp Log Message: Protect the undo history, even if an error is signalled somewhere. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/14 20:35:44 1.43 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/06 17:31:50 1.44 @@ -107,16 +107,16 @@ (let ((buffer-var (gensym))) `(let ((,buffer-var ,buffer)) (setf (undo-accumulate ,buffer-var) '()) - ,@body - (cond ((null (undo-accumulate ,buffer-var)) nil) - ((null (cdr (undo-accumulate ,buffer-var))) - (add-undo (car (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var))) - (t - (add-undo (make-instance 'compound-record - :buffer ,buffer-var - :records (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var))))))) + (unwind-protect (progn ,@body) + (cond ((null (undo-accumulate ,buffer-var)) nil) + ((null (cdr (undo-accumulate ,buffer-var))) + (add-undo (car (undo-accumulate ,buffer-var)) + (undo-tree ,buffer-var))) + (t + (add-undo (make-instance 'compound-record + :buffer ,buffer-var + :records (undo-accumulate ,buffer-var)) + (undo-tree ,buffer-var)))))))) (defmethod flip-undo-record :around ((record climacs-undo-record)) (with-slots (buffer) record

1 0

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

05 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25453 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp climacs.asd Added Files: lisp-syntax-swank.lisp Log Message: Added conditionally loaded Swine-functionality to the Lisp syntax. Please report any breakage. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/13 14:58:37 1.88 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/05 13:52:17 1.89 @@ -24,6 +24,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Convenience functions and macros: + +(defun unlisted (obj) + (if (listp obj) + (first obj) + obj)) + +(defun listed (obj) + (if (listp obj) + obj + (list obj))) + +(defun usable-package (package-designator) + "Return a usable package based on `package-designator'." + (or (find-package package-designator) + *package*)) + +(defmacro evaluating-interactively (&body body) + `(handler-case (progn ,@body) + (end-of-file () + (esa:display-message "Unbalanced parentheses in form.")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; The command table. (make-command-table 'lisp-table @@ -57,7 +81,12 @@ :documentation "The package specified in the attribute line (may be overridden - by (in-package) forms).")) + by (in-package) forms).") + (image :accessor image + :initform nil + :documentation "An image object (or NIL) that + determines where and how Lisp code in the buffer of the + syntax should be run.")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) @@ -80,6 +109,106 @@ (format nil "Lisp~@[:~(~A~)~]" (package-name (package-at-mark syntax (point pane))))) +(defgeneric default-image () + (:documentation "The default image for when the current syntax + does not mandate anything itself (for example if it is not a + Lisp syntax).") + (:method () + t)) + +(defgeneric get-usable-image (syntax) + (:documentation "Get usable image object from `syntax'.") + (:method (syntax) + (default-image)) + (:method ((syntax lisp-syntax)) + (or (image syntax) + (default-image)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Swank interface functions: + +(defgeneric eval-string-for-climacs (image string package) + (:documentation "Evaluate `string' in `package'. A single value +is returned: The result of evaluating `string'.") + (:method (image string package) + (let ((*package* package)) + (eval-form-for-climacs image (read-from-string string))))) + +(defgeneric eval-form-for-climacs (image form) + (:documentation "Evaluate `string' in `package'. A single value +is returned: The result of evaluating `string'.") + (:method (image form) + (declare (ignore image)) + (eval form))) + +(defgeneric compile-string-for-climacs (image string package buffer buffer-mark) + (:documentation "Compile and evaluate `string' in +`package'. Two values are returned: The result of evaluating +`string' and a list of compiler notes. `Buffer' and `buffer-mark' +will be used for hyperlinking the compiler notes to the source +code.") + (:method (image string package buffer buffer-mark) + (declare (ignore image string package buffer buffer-mark)) + (error "Backend insufficient for this operation"))) + +(defgeneric compile-form-for-climacs (image form buffer buffer-mark) + (:documentation "Compile and evaluate `form', which must be a +valid Lisp form. Two values are returned: The result of +evaluating `string' and a list of compiler notes. `Buffer' and +`buffer-mark' will be used for hyperlinking the compiler notes to +the source code.") + (:method (image form buffer buffer-mark) + (compile-string-for-climacs image + (write-to-string form) + *package* buffer buffer-mark))) + +(defgeneric compile-file-for-climacs (image filepath package &optional load-p) + (:documentation "Compile the file at `filepath' in +`package'. If `load-p' is non-NIL, also load the file at +`filepath'. Two values will be returned: the result of compiling +the file and a list of compiler notes.") + (:method (image filepath package &optional load-p) + (declare (ignore image filepath package load-p)) + (error "Backend insufficient for this operation"))) + +(defgeneric macroexpand-for-climacs (image form &optional full-p) + (:documentation "Macroexpand `form' and return result.") + (:method (image form &optional full-p) + (declare (ignore image)) + (funcall (if full-p + #'macroexpand + #'macroexpand-1) + form))) + +(defgeneric find-definitions-for-climacs (image symbol) + (:documentation "Return list of definitions for `symbol'.") + (:method (image symbol) + (declare (ignore image symbol)))) + +(defgeneric get-class-keyword-parameters (image class) + (:documentation "Get a list of keyword parameters (possibly +along with any default values) that can be used in a +`make-instance' form for `class'.") + (:method (image class) + (declare (ignore image class)))) + +(defgeneric arglist (image symbol) + (:documentation "Get plain arglist for symbol.") + (:method (image symbol) + (declare (ignore image symbol)))) + +(defgeneric simple-completions (image string default-package) + (:documentation "Return a list of simple symbol-completions for +`string' in `default-package'.") + (:method (image string default-package) + (declare (ignore image string default-package)))) + +(defgeneric fuzzy-completions (image symbol-name default-package &optional limit) + (:documentation "Return a list of fuzzy completions for `symbol-name'.") + (:method (image symbol-name default-package &optional limit) + (declare (ignore image symbol-name default-package limit)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer @@ -1416,6 +1545,34 @@ form)))) (unwrap-form (expression-at-mark mark syntax)))) +(defun this-form (mark syntax) + "Return a form at mark. This function defines which + forms the COM-FOO-this commands affect." + (or (form-around syntax (offset mark)) + (form-before syntax (offset mark)))) + +(defun preceding-form (mark syntax) + "Return a form at mark." + (or (form-before syntax (offset mark)) + (form-around syntax (offset mark)))) + +(defun text-of-definition-at-mark (mark syntax) + "Return the text of the definition at mark." + (let ((definition (definition-at-mark mark syntax))) + (buffer-substring (buffer mark) + (start-offset definition) + (end-offset definition)))) + +(defun text-of-expression-at-mark (mark syntax) + "Return the text of the expression at mark." + (let ((expression (expression-at-mark mark syntax))) + (token-string syntax expression))) + +(defun symbol-name-at-mark (mark syntax) + "Return the text of the symbol at mark." + (let ((token (symbol-at-mark mark syntax))) + (when token (token-string syntax token)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -1462,7 +1619,7 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (< start end) - do (ecase (buffer-object buffer start) + do (case (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) (multiple-value-bind (x y) (stream-cursor-position pane) @@ -1826,16 +1983,16 @@ (defmethod backward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) - (if potential-form - (setf (offset mark) (start-offset potential-form)) - (error 'no-expression)))) + (when (and (not (null potential-form)) + (not (= (offset mark) (start-offset potential-form)))) + (setf (offset mark) (start-offset potential-form))))) (defmethod forward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) - (if potential-form - (setf (offset mark) (end-offset potential-form)) - (error 'no-expression)))) + (when (and (not (null potential-form)) + (not (= (offset mark) (end-offset potential-form)))) + (setf (offset mark) (end-offset potential-form))))) (defgeneric forward-one-list (mark syntax) (:documentation @@ -1917,8 +2074,9 @@ (loop for form in (children stack-top) when (and (mark<= (start-offset form) mark) (mark<= mark (end-offset form))) - do (return (eval (read-from-string - (token-string syntax form))))))) + do (return (eval-form-for-climacs + (get-usable-image syntax) + (token-to-object syntax form :read t)))))) (defmethod backward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax @@ -2139,7 +2297,7 @@ (flet ((act () (with-syntax-package syntax (start-offset token) (syntax-package) - (let ((*package* syntax-package)) + (let ((*package* (or package syntax-package))) (cond (read (read-from-string (token-string syntax token))) (quote @@ -2350,11 +2508,25 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level - (if (= (car path) 2) - ;; indent like first child - (values (elt-noncomment (children tree) 1) 0) - ;; indent like second child - (values (elt-noncomment (children tree) 2) 0)) + (let* ((arglist (when (fboundp symbol) (arglist (get-usable-image syntax) symbol))) + (body-or-rest-pos (or (position '&body arglist) + (position '&rest arglist)))) + (if (and (or (macro-function symbol) + (special-operator-p symbol)) + (and (not (null body-or-rest-pos)) + (plusp body-or-rest-pos))) + ;; macro-form with "interesting" arguments. + (if (>= (- (car path) 2) body-or-rest-pos) + ;; &body arg. + (values (elt-noncomment (children tree) 1) 1) + ;; non-&body-arg. + (values (elt-noncomment (children tree) 1) 3)) + ;; normal form. + (if (= (car path) 2) + ;; indent like first child + (values (elt-noncomment (children tree) 1) 0) + ;; indent like second child + (values (elt-noncomment (children tree) 2) 0)))) ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) @@ -2607,3 +2779,1002 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Swine + +;;; Compiler note hyperlinking code + +(defun make-compiler-note (note-list) + (let ((severity (getf note-list :severity)) + (message (getf note-list :message)) + (location (getf note-list :location)) + (references (getf note-list :references)) + (short-message (getf note-list :short-message))) + (make-instance + (ecase severity + (:error 'error-compiler-note) + (:read-error 'read-error-compiler-note) + (:warning 'warning-compiler-note) + (:style-warning 'style-warning-compiler-note) + (:note 'note-compiler-note)) + :message message :location location + :references references :short-message short-message))) + +(defclass compiler-note () + ((message :initarg :message :initform nil :accessor message) + (location :initarg :location :initform nil :accessor location) + (references :initarg :references :initform nil :accessor references) + (short-message :initarg :short-message :initform nil :accessor short-message)) + (:documentation "The base for all compiler-notes.")) + +(defclass error-compiler-note (compiler-note) ()) + +(defclass read-error-compiler-note (compiler-note) ()) + +(defclass warning-compiler-note (compiler-note) ()) + +(defclass style-warning-compiler-note (compiler-note) ()) + +(defclass note-compiler-note (compiler-note) ()) + +(defclass location ()() + (:documentation "The base for all locations.")) + +(defclass error-location (location) + ((error-message :initarg :error-message :accessor error-message))) + +(defclass actual-location (location) + ((source-position :initarg :position :accessor source-position) + (snippet :initarg :snippet :accessor snippet :initform nil)) + (:documentation "The base for all non-error locations.")) + +(defclass buffer-location (actual-location) + ((buffer-name :initarg :buffer :accessor buffer-name))) + +(defclass file-location (actual-location) + ((file-name :initarg :file :accessor file-name))) + +(defclass source-location (actual-location) + ((source-form :initarg :source-form :accessor source-form))) + +(defclass basic-position () () + (:documentation "The base for all positions.")) + +(defclass char-position (basic-position) + ((char-position :initarg :position :accessor char-position) + (align-p :initarg :align-p :initform nil :accessor align-p))) + +(defun make-char-position (position-list) + (make-instance 'char-position :position (second position-list) + :align-p (third position-list))) + +(defclass line-position (basic-position) + ((start-line :initarg :line :accessor start-line) + (end-line :initarg :end-line :initform nil :accessor end-line))) + +(defun make-line-position (position-list) + (make-instance 'line-position :line (second position-list) + :end-line (third position-list))) + +(defclass function-name-position (basic-position) + ((function-name :initarg :function-name))) + +(defun make-function-name-position (position-list) + (make-instance 'function-name-position :function-name (second position-list))) + +(defclass source-path-position (basic-position) + ((path :initarg :source-path :accessor path) + (start-position :initarg :start-position :accessor start-position))) + +(defun make-source-path-position (position-list) + (make-instance 'source-path-position :source-path (second position-list) + :start-position (third position-list))) + +(defclass text-anchored-position (basic-position) + ((start :initarg :text-anchored :accessor start) + (text :initarg :text :accessor text) + (delta :initarg :delta :accessor delta))) + +(defun make-text-anchored-position (position-list) + (make-instance 'text-anchored-position :text-anchored (second position-list) + :text (third position-list) + :delta (fourth position-list))) + +(defclass method-position (basic-position) + ((name :initarg :method :accessor name) + (specializers :initarg :specializers :accessor specializers) + (qualifiers :initarg :qualifiers :accessor qualifiers))) + +(defun make-method-position (position-list) + (make-instance 'method-position :method (second position-list) + :specializers (third position-list) + :qualifiers (last position-list))) + +(defun make-location (location-list) + (ecase (first location-list) + (:error (make-instance 'error-location :error-message (second location-list))) + (:location + (destructuring-bind (l buf pos hints) location-list + (declare (ignore l)) + (let ((location + (apply #'make-instance + (ecase (first buf) + (:file 'file-location) + (:buffer 'buffer-location) [876 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/12 19:10:58 1.6 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/05 13:52:17 1.7 @@ -96,6 +96,209 @@ (loop repeat (- count) do (backward-expression mark syntax))) (climacs-editing:indent-region pane (clone-mark point) mark))) +(define-command (com-eval-last-expression :name t :command-table lisp-table) + ((insertp 'boolean :prompt "Insert?")) + "Evaluate the expression before point in the local Lisp image." + (let* ((syntax (syntax (buffer (current-window)))) + (mark (point (current-window))) + (token (form-before syntax (offset mark)))) + (if token + (with-syntax-package syntax mark (package) + (let ((*package* package)) + (climacs-gui::com-eval-expression + (token-to-object syntax token :read t) + insertp))) + (esa:display-message "Nothing to evaluate.")))) + +(define-command (com-macroexpand-1 :name t :command-table lisp-table) + () + "Macroexpand-1 the expression at point. + +The expanded expression will be displayed in a +\"*Macroexpansion*\"-buffer." + (let* ((syntax (syntax (buffer (current-window)))) + (token (expression-at-mark (point (current-window)) syntax))) + (if token + (macroexpand-token syntax token) + (esa:display-message "Nothing to expand at point.")))) + +(define-command (com-macroexpand-all :name t :command-table lisp-table) + () + "Completely macroexpand the expression at point. + +The expanded expression will be displayed in a +\"*Macroexpansion*\"-buffer." + (let* ((syntax (syntax (buffer (current-window)))) + (token (expression-at-mark (point (current-window)) syntax))) + (if token + (macroexpand-token syntax token t) + (esa:display-message "Nothing to expand at point.")))) + +(define-command (com-eval-region :name t :command-table lisp-table) + () + "Evaluate the current region." + (let ((mark (mark (current-window))) + (point (point (current-window)))) + (when (mark> mark point) + (rotatef mark point)) + (evaluating-interactively + (eval-region mark point + (syntax (buffer (current-window))))))) + +(define-command (com-compile-definition :name t :command-table lisp-table) + () + "Compile and load definition at point." + (evaluating-interactively + (compile-definition-interactively (point (current-window)) + (syntax (buffer (current-window)))))) + +(define-command (com-compile-and-load-file :name t :command-table lisp-table) + () + "Compile and load the current file. + +Compiler notes will be displayed in a seperate buffer." + (compile-file-interactively (buffer (current-window)) t)) + +(define-command (com-compile-file :name t :command-table lisp-table) + () + "Compile the file open in the current buffer. + +This command does not load the file after it has been compiled." + (compile-file-interactively (buffer (current-window)) nil)) + +(define-command (com-goto-location :name t :command-table lisp-table) + ((note 'compiler-note)) + "Move point to the part of a given file that caused the +compiler note. + +If the file is not already open, a new buffer will be opened with +that file." + (goto-location (location note))) + +(define-presentation-to-command-translator compiler-note-to-goto-location-translator + (compiler-note com-goto-location lisp-table) + (presentation) + (list (presentation-object presentation))) + +(define-command (com-goto-xref :name t :command-table lisp-table) + ((xref 'xref)) + "Go to the referenced location of a code cross-reference." + (goto-location xref)) + +(define-presentation-to-command-translator xref-to-goto-location-translator + (xref com-goto-xref lisp-table) + (presentation) + (list (presentation-object presentation))) + +(define-command (com-edit-this-definition :command-table lisp-table) + () + "Edit definition of the symbol at point. +If there is no symbol at point, this is a no-op." + (let* ((buffer (buffer (current-window))) + (point (point (current-window))) + (syntax (syntax buffer)) + (token (this-form point syntax)) + (this-symbol (when token (token-to-object syntax token)))) + (when (and this-symbol (symbolp this-symbol)) + (edit-definition this-symbol)))) + +(define-command (com-return-from-definition :name t :command-table lisp-table) + () + "Return point to where it was before the previous Edit +Definition command was issued." + (pop-find-definition-stack)) + +(define-command (com-lookup-arglist-for-this-symbol :command-table lisp-table) + () + "Show argument list for symbol at point." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (mark (point pane)) + (token (this-form mark syntax))) + (if (and token (typep token 'complete-token-lexeme)) + (com-lookup-arglist (token-to-object syntax token)) + (esa:display-message "Could not find symbol at point.")))) + +(define-command (com-lookup-arglist :name t :command-table lisp-table) + ((symbol 'symbol :prompt "Symbol")) + "Show argument list for a given symbol." + (show-arglist symbol)) + +(define-command (com-space :command-table lisp-table) + () + "Insert a space and display argument hints in the minibuffer." + (let* ((window (current-window)) + (mark (point window)) + (syntax (syntax (buffer window)))) + ;; It is important that the space is inserted before we look up + ;; any symbols, but at the same time, there must not be a space + ;; between the mark and the symbol. + (insert-character #\Space) + (backward-object mark) + ;; We must update the syntax in order to reflect any changes to + ;; the parse tree our insertion of a space character may have + ;; done. + (update-syntax (buffer syntax) syntax) + (show-arglist-for-form-at-mark mark syntax) + (forward-object mark) + (clear-completions))) + +(define-command (com-complete-symbol :name t :command-table lisp-table) () + "Attempt to complete the symbol at mark. + +If more than one completion is available, a list of possible +completions will be displayed." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) + (name (symbol-name-at-mark point-current-window + syntax))) + (when name + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-completions syntax name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) + +(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () + "Attempt to fuzzily complete the abbreviation at mark. + +Fuzzy completion tries to guess which symbol is abbreviated. If +the abbreviation is ambiguous, a list of possible completions +will be displayed." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) + (name (symbol-name-at-mark point-current-window + syntax))) + (when name + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-fuzzy-completions syntax name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) + +(define-presentation-to-command-translator lookup-symbol-arglist + (symbol com-lookup-arglist lisp-table + :gesture :describe + :tester ((object presentation) + (declare (ignore object)) + (not (eq (presentation-type presentation) 'unknown-symbol))) + :documentation "Lookup arglist") + (object) + (list object)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Gesture bindings + (esa:set-key 'com-fill-paragraph 'lisp-table '((#\q :meta))) @@ -142,4 +345,61 @@ (esa:set-key `(com-kill-expression ,*numeric-argument-marker*) 'lisp-table - '((#\k :control :meta))) \ No newline at end of file + '((#\k :control :meta))) + +(esa:set-key `(com-eval-last-expression ,esa:*numeric-argument-p*) + 'lisp-table + '((#\c :control) (#\e :control))) + +(esa:set-key 'com-macroexpand-1 + 'lisp-table + '((#\c :control) (#\Newline))) + +(esa:set-key 'com-macroexpand-1 + 'lisp-table + '((#\c :control) (#\m :control))) + +(esa:set-key 'com-eval-region + 'lisp-table + '((#\c :control) (#\r :control))) + +(esa:set-key 'com-compile-definition + 'lisp-table + '((#\c :control) (#\c :control))) + +(esa:set-key 'com-compile-and-load-file + 'lisp-table + '((#\c :control) (#\k :control))) + +(esa:set-key 'com-compile-file + 'lisp-table + '((#\c :control) (#\k :meta))) + +(esa:set-key `(com-edit-this-definition) + 'lisp-table + '((#\. :meta))) + +(esa:set-key 'com-return-from-definition + 'lisp-table + '((#\, :meta))) + +(esa:set-key 'com-hyperspec-lookup + 'lisp-table + '((#\c :control) (#\d :control) (#\h))) + +(esa:set-key `(com-lookup-arglist-for-this-symbol) + 'lisp-table + '((#\c :control) (#\d :control) (#\a))) + +(esa:set-key 'com-space + 'lisp-table + '((#\Space))) + +(esa:set-key 'com-complete-symbol + 'lisp-table + '((#\Tab :meta))) + +(esa:set-key 'com-fuzzily-complete-symbol + 'lisp-table + '((#\c :control) (#\i :meta))) + --- /project/climacs/cvsroot/climacs/climacs.asd 2006/06/12 19:10:58 1.45 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/05 13:52:17 1.46 @@ -27,8 +27,18 @@ (defparameter *climacs-directory* (directory-namestring *load-truename*)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun find-swank-package () + (find-package :swank)) + (defun find-swank-system () + (handler-case (asdf:find-system :swank) + (asdf:missing-component ()))) + (defun find-swank () + (or (find-swank-package) + (find-swank-system)))) + (defsystem :climacs - :depends-on (:mcclim :flexichain :esa :split-sequence) + :depends-on (:mcclim :flexichain :esa #.(if (find-swank-system) :swank (values))) :components ((:module "cl-automaton" :components ((:file "automaton-package") @@ -73,8 +83,11 @@ (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" - "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands")) + "window-commands" "gui")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" "misc-commands" "window-commands" "file-commands")) + #.(if (find-swank) + '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) + (values)) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" "abbrev" "editing" "motion")) --- /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 NONE +++ /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*- ;;; (c) copyright 2005-2006 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; David Murray (splittist(a)yahoo.com) ;;; 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 ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; An implementation of some of the editor-centric functionality of ;;; the Lisp syntax using calls to Swank functions. (in-package :climacs-lisp-syntax) (defclass swank-local-image () ()) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image. (defmethod shared-initialize :after ((obj lisp-syntax) slot-names &key) (declare (ignore slot-names)) (setf (image obj) (make-instance 'swank-local-image))) (defmethod default-image () (make-instance 'swank-local-image)) (define-command (com-enable-swank-for-buffer :name t :command-table lisp-table) () (unless (find-package :swank) (let ((*standard-output* *terminal-io*)) (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) (setf (image (syntax (current-buffer))) (make-instance 'swank-local-image))) (defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark) (declare (ignore image)) (let* ((buffer-name (name buffer)) (buffer-file-name (filepath buffer)) ;; swank::compile-string-for-emacs binds *compile-verbose* to t ;; so we need to do this to avoid scribbles on the pane (*standard-output* *debug-io*) (swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*)) (let ((result (swank::compile-string-for-emacs string buffer-name (offset buffer-mark) buffer-file-name)) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes)))) (defmethod compile-file-for-climacs ((image swank-local-image) filepath package &optional load-p) (declare (ignore image)) (let* ((swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*) (*compile-verbose* nil) (result (swank::compile-file-for-emacs filepath load-p)) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes))) (defmethod find-definitions-for-climacs ((image swank-local-image) symbol) (declare (ignore image)) (flet ((fully-qualified-symbol-name (symbol) (let ((*package* (find-package :keyword))) (format nil "~S" symbol)))) (let* ((name (fully-qualified-symbol-name symbol)) (swank::*buffer-package* *package*) (swank::*buffer-readtable* *readtable*)) (swank::find-definitions-for-emacs name)))) (defmethod get-class-keyword-parameters ((image swank-local-image) class) (declare (ignore image)) (loop for arg in (swank::extra-keywords/make-instance 'make-instance class) if (swank::keyword-arg.default-arg arg) collect (list (swank::keyword-arg.arg-name arg) (swank::keyword-arg.default-arg arg)) else collect (swank::keyword-arg.arg-name arg))) (defmethod arglist ((image swank-local-image) symbol) (declare (ignore image)) (swank::arglist symbol)) (defmethod simple-completions ((image swank-local-image) string default-package) (declare (ignore image)) (swank::completions string (package-name default-package))) (defmethod fuzzy-completions ((image swank-local-image) symbol-name default-package &optional limit) (declare (ignore image)) (swank::fuzzy-completions symbol-name (package-name default-package) limit))

1 0

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

03 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9935 Modified Files: packages.lisp base.lisp Log Message: Added `just-n-spaces' function. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/06/12 19:10:58 1.100 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/03 15:46:53 1.101 @@ -75,6 +75,7 @@ #:buffer-display-column #:number-of-lines-in-region #:constituentp + #:just-n-spaces #:forward-word #:backward-word #:buffer-region-case #:input-from-stream #:output-to-stream --- /project/climacs/cvsroot/climacs/base.lisp 2006/06/29 14:23:26 1.52 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/03 15:46:53 1.53 @@ -144,6 +144,29 @@ function does not respect the current syntax." (member obj '(#\Space #\Tab #\Newline #\Page #\Return))) +(defun just-n-spaces (mark1 n) + "Remove all spaces around `mark', leaving behind `n' +spaces. `Mark' will be moved to after any spaces inserted." + (let ((mark2 (clone-mark mark1))) + (loop + while (not (beginning-of-buffer-p mark2)) + while (eql (object-before mark2) #\Space) + do (backward-object mark2)) + (loop + while (not (end-of-buffer-p mark1)) + while (eql (object-after mark1) #\Space) + do (forward-object mark1)) + (let ((existing-spaces (- (offset mark1) + (offset mark2)))) + (cond ((= n existing-spaces)) + ((> n existing-spaces) + (insert-sequence mark1 (make-array (- n existing-spaces) + :initial-element #\Space))) + ((< n existing-spaces) + (delete-region (- (offset mark1) + (- existing-spaces n)) + mark1)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv994/Doc Modified Files: climacs-user.texi Log Message: Fleshed out the definitions for the buffer and pane concepts. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:34:15 1.11 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:55:45 1.12 @@ -108,9 +108,16 @@ A @climacs{} @emph{buffer} @cindex buffer -is an editable sequence of arbitrary @cl{} objects. If the buffer +is a named, editable sequence of arbitrary @cl{} objects. If the buffer contains text, most of those objects will be @emph{Unicode -characters}. +characters}. When editing a file, the contents of the file will be +loaded into a buffer with a name corresponding to the name of the file +(creating the buffer in the process), and all editing operations will be +performed on the buffer. Upon saving, the contents of the buffer will be +written to the file associated with it. @xref{Editing the contents of a +file}. A buffer does not necessarily have a file associated with it, for +example, the @emph{*scratch*} buffer automatically created upon +@climacs{} startup is not associated with any file. @cindex character @cindex Unicode @@ -118,10 +125,15 @@ @section Window and pane A @climacs{} buffer may or may not be on display. If it is, it is on -display in a @emph{pane} +display in a @emph{pane} @cindex pane or a @emph{window}. @cindex window +A pane does not necessarily contain a buffer, it may just be a pane +containing output from Climacs. These panes are known as @emph{typeout +panes}, +@cindex typeout pane +and their contents are lost when they are destroyed. @node Mark and point @section Mark and point @@ -731,8 +743,8 @@ To get documentation about a particular command, use the order @kbd{C-h f} @kindex C-h f -(@command{Describe Command}). You will be prompted for -the name of a command, and if you provide a valid command name, a pane +(@command{Describe Command}). You will be prompted for the name of a +command, and if you provide a valid command name, a typeout pane containing information about which function the command calls, which gestures the command can be invoked through, as well as a description of the command, will be displayed. @@ -762,20 +774,21 @@ (@command{Describe Key}). You will be prompted for a key sequence, and if the key sequence you provide is bound to a command, documentation for that command, as well as any arguments the given key binding calls the -command with, will be shown. +command with, will be shown in a typeout pane. @node Help finding a command -@section Help findind a command +@section Help finding a command If you do not know which commands are applicable to a given situation, you can use the order @kbd{C-h a} @kindex C-h a (@command{Apropos Command}) to perform a keyword-based search for -commands. You will be prompted for a keyword, after which @climacs{} will -search through the available commands for commands that are connected to -the keyword. If commands are found, they will be displayed in a pane -along with the gestures you can use to invoke them. You can also click -on the names of the commands to get more thorough documentation. +commands. You will be prompted for a keyword, after which @climacs{} +will search through the available commands for commands that are +connected to the keyword. If commands are found, they will be displayed +in a typeout pane along with the gestures you can use to invoke +them. You can also click on the names of the commands to get more +thorough documentation. @node Help finding an order for a command @section Help finding an order for a command

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv31495/Doc Modified Files: climacs-user.texi Log Message: Climacs => @climacs{} (but why?) --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:01:33 1.10 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:34:15 1.11 @@ -556,7 +556,7 @@ @node Searching and replacing @section Searching and replacing -Climacs has a number of useful searching and replacing commands. The +@climacs{} has a number of useful searching and replacing commands. The replacing commands come in two flavors - querying commands and non-querying commands. The former will unconditionally replace all matches, while the latter will query before each replacement. Note that @@ -619,7 +619,7 @@ @subsection The isearch command loop The isearch command loop consists of the user typing in characters for -the search string, and Climacs moving point ahead to the most immediate +the search string, and @climacs{} moving point ahead to the most immediate instance of the provided string, while the user is typing. Apart from simply entering text, the user can manipulate the command loop by entering the following orders: @@ -669,7 +669,7 @@ with one command - for instance, you might want to replace all occurrences of ``foo'' with ``bar'' and all occurrences of ``bar'' with ``baz'', without having the replacements affect each other. For this, -Climacs provides the command @command{Multiple Query Replace}, which +@climacs{} provides the command @command{Multiple Query Replace}, which will prompt for pairs of strings, replacing the first with the second. Entering an empty search string stops the prompting and starts the query-replace command loop. It is also possible to use @command{Multiple @@ -771,7 +771,7 @@ you can use the order @kbd{C-h a} @kindex C-h a (@command{Apropos Command}) to perform a keyword-based search for -commands. You will be prompted for a keyword, after which Climacs will +commands. You will be prompted for a keyword, after which @climacs{} will search through the available commands for commands that are connected to the keyword. If commands are found, they will be displayed in a pane along with the gestures you can use to invoke them. You can also click

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv27509/Doc Modified Files: climacs-user.texi Log Message: Added documentation for the search/replace-commands to the Climacs User Guide. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 23:11:19 1.9 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:01:33 1.10 @@ -556,6 +556,156 @@ @node Searching and replacing @section Searching and replacing +Climacs has a number of useful searching and replacing commands. The +replacing commands come in two flavors - querying commands and +non-querying commands. The former will unconditionally replace all +matches, while the latter will query before each replacement. Note that +the searching and replacing commands only affect the buffer contents +after point. + +@menu +* Simple search:: +* Incremental search:: +* The isearch command loop:: +* Replacing single strings:: +* Replacing multiple different strings:: +* The query-replace command loop:: +@end menu + +@node Simple search +@subsection Simple search + +The simplest search command is @command{String Search}. It prompts for a +string and moves point to after the next occurrence of the +string. @command{Reverse String Search} is similar, but searches +backwards from point, and puts point before the first occurrence of the +string. + +The commands @command{Word Search} and @command{Reverse Word Search} are +very similar to @command{String Search} and @command{Reverse String +Search}, but only finds matches that are whole words. + +The commands @command{Regex Search Forward} and @command{Regex Search +Backward} are similar to @command{String Search} and @command{Reverse +Word Search}, but do not search for plain strings. Instead, they ask the +user to enter a regular expression and attempts to find a match in the +buffer. + +You can use the command @command{How Many} to count the number of +matches in the buffer for a given regular expression. When invoked, the +command will ask for a regular expression, and then proceed to search +through the buffer, counting each match for the regular expression, and +finally print the number of matches to the minibuffer. + +@node Incremental search +@subsection Incremental search + +Incremental search, or @emph{isearch} in common speech, is different +from string search, in that point is moved to matches in the buffer, +while the search string is being entered, thus, the user receives +immediate feedback while entering the search string. Incremental search +is controlled through a command loop. @xref{The isearch command loop}. + +Incremental search can be entered via two orders, @kbd{C-s} +@kindex C-s +(@command{Isearch Forward}) and @kbd{C-r} +@kindex C-r +(@command{Isearch Backward}). These commands starts a command loop that +searches forwards and backwards by default, respectively. Note that the +search direction can be changed from inside the command loop, no matter +which of these commands were used to start it. + +@node The isearch command loop +@subsection The isearch command loop + +The isearch command loop consists of the user typing in characters for +the search string, and Climacs moving point ahead to the most immediate +instance of the provided string, while the user is typing. Apart from +simply entering text, the user can manipulate the command loop by +entering the following orders: + +@table @kbd +@item C-s +Move to next match for current search string and set the search +direction to forward. +@item C-r +Move to previous match for current search string and set the search +direction to backward. +@item C-j +Append a ``newline'' character to the current search string. +@item C-w +Append the word at point to the current search string. +@item C-y +Append the line at point to the current search string. +@item M-y +Append the head of the kill ring to the search string. +@item @key{Backspace} +Delete the last element of the search string. This is not the same as +deleting the last character - for example, if the word at point has been +appended to the search string via @kbd{C-w}, this order will delete the +entire word, not just the last character of the word. +@item @key{Newline} +Exit the isearch command loop. +@end table + +@node Replacing single strings +@subsection Replacing single strings + +The basic string-replacement command can be accessed through the order +@kbd{C-x e} +@kindex C-x e +(@command{Replace String}). This command will prompt for two strings, +and replace all instances of the first string following point in the +current buffer, with the second string. This command is not querying, +and will thus not prompt before each replacement, so if you desire this +behavior, use the order @kbd{M-%} +@kindex M-% +(@command{Query Replace}) instead. @xref{The query-replace command loop}. + +@node Replacing multiple different strings +@subsection Replacing multiple different strings + +It is often desirable to be able to replace multiple, different strings +with one command - for instance, you might want to replace all +occurrences of ``foo'' with ``bar'' and all occurrences of ``bar'' with +``baz'', without having the replacements affect each other. For this, +Climacs provides the command @command{Multiple Query Replace}, which +will prompt for pairs of strings, replacing the first with the second. +Entering an empty search string stops the prompting and starts the +query-replace command loop. It is also possible to use @command{Multiple +Query Replace From Buffer}, which will read the string pairs from a +buffer provided by the user. + +If you wish to exchange two strings for one another, use the command +@command{Query Exchange}, which will prompt for two strings, and replace +them for each other in the current buffer. + +@node The query-replace command loop +@subsection The query-replace command loop + +When invoking one of the querying replace commands, you will enter a +command loop with specialized commands for manipulating the replacement +process. + +The command loop will loop across the buffer, and for each match, the +command loop will read an order from the user. The following orders and +their corresponding commands are available: + +@table @kbd +@item y, @key{Space} +Replace the current match with the provided string, go to next +match. +@item n, @key{Rubout}, @key{Backspace} +Do not replace the current match, go to next match. +@item q, @key{Newline} +Quit the command loop, preserving all replacements already made. +@item . +Replace the current match with the provided string and quit the +command loop. +@item ! +Replace all matches with the provided replacement strings. +@end table + @node Getting help @chapter Getting help @@ -568,8 +718,10 @@ information is displayed. @menu +* Help with a command:: * Help with a key binding:: * Help with a particular key sequence:: +* Help finding a command:: * Help finding an order for a command:: @end menu @@ -598,7 +750,7 @@ @section Help with a particular key sequence To obtain a description of what some putative order will do, use the -order @kbd{C-h c} +order @kbd{C-h c}p @kindex C-h c (@command{Describe Key Briefly}). You will be prompted for a key sequence. If the key sequence you type is bound to a command, the

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22006 Modified Files: search-commands.lisp Log Message: Fixed `com-isearch-append-word' to work with the new motion methods. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/06/12 19:10:58 1.7 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/02 18:42:28 1.8 @@ -199,7 +199,9 @@ (isearch-from-mark pane mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () - (isearch-append-text #'forward-word)) + (let ((syntax (syntax (current-buffer)))) + (isearch-append-text #'(lambda (mark) + (forward-word mark syntax))))) (define-command (com-isearch-append-line :name t :command-table isearch-climacs-table) () (isearch-append-text #'end-of-line))

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26319 Modified Files: misc-commands.lisp editing-commands.lisp Log Message: Moved the Kill Line command into editing-commands.lisp. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/12 19:10:58 1.15 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/02 15:43:48 1.16 @@ -150,53 +150,6 @@ 'editing-table '((#\o :control))) -(defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) - (let ((start (offset mark))) - (cond ((= 0 count) - (beginning-of-line mark)) - ((< count 0) - (loop repeat (- count) - until (beginning-of-buffer-p mark) - do (beginning-of-line mark) - until (beginning-of-buffer-p mark) - do (backward-object mark))) - ((or whole-lines-p (> count 1)) - (loop repeat count - until (end-of-buffer-p mark) - do (end-of-line mark) - until (end-of-buffer-p mark) - do (forward-object mark))) - (t - (cond ((end-of-buffer-p mark) nil) - ((end-of-line-p mark) (forward-object mark)) - (t (end-of-line mark))))) - (unless (mark= mark start) - (if concatenate-p - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence start mark)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence start mark))) - (delete-region start mark)))) - -(define-command (com-kill-line :name t :command-table deletion-table) - ((numarg 'integer :prompt "Kill how many lines?") - (numargp 'boolean :prompt "Kill entire lines?")) - "Kill the objects on the current line after point. -When at the end of a line, kill the #\\Newline. -With a numeric argument of 0, kill the objects on the current line before point. -With a non-zero numeric argument, kill that many lines forward (backward, -if negative) from point. - -Successive kills append to the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (concatenate-p (eq (previous-command pane) 'com-kill-line))) - (kill-line point numarg numargp concatenate-p))) - -(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*) - 'deletion-table - '((#\k :control))) - (defmacro define-mark-unit-command (unit command-table &key move-point noun --- /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/07/02 15:43:48 1.2 @@ -195,13 +195,57 @@ (region-to-sequence mark point))) (delete-region mark point))) +;; We require somewhat special behavior from Kill Line, so define a +;; new function and use that to implement the Kill Line command. +(defun user-kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) + (let ((start (offset mark))) + (cond ((= 0 count) + (beginning-of-line mark)) + ((< count 0) + (loop repeat (- count) + until (beginning-of-buffer-p mark) + do (beginning-of-line mark) + until (beginning-of-buffer-p mark) + do (backward-object mark))) + ((or whole-lines-p (> count 1)) + (loop repeat count + until (end-of-buffer-p mark) + do (end-of-line mark) + until (end-of-buffer-p mark) + do (forward-object mark))) + (t + (cond ((end-of-buffer-p mark) nil) + ((end-of-line-p mark) (forward-object mark)) + (t (end-of-line mark))))) + (unless (mark= mark start) + (if concatenate-p + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence start mark)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence start mark))) + (delete-region start mark)))) + +(define-command (com-kill-line :name t :command-table deletion-table) + ((numarg 'integer :prompt "Kill how many lines?") + (numargp 'boolean :prompt "Kill entire lines?")) + "Kill the objects on the current line after point. +When at the end of a line, kill the #\\Newline. +With a numeric argument of 0, kill the objects on the current line before point. +With a non-zero numeric argument, kill that many lines forward (backward, +if negative) from point. + +Successive kills append to the kill ring." + (let* ((pane (current-window)) + (point (point pane)) + (concatenate-p (eq (previous-command pane) 'com-kill-line))) + (user-kill-line point numarg numargp concatenate-p))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Autogenerate commands (define-deletion-commands word deletion-table) (define-editing-commands word editing-table) -(define-deletion-commands line deletion-table) (define-editing-commands line editing-table) (define-deletion-commands definition deletion-table) (define-editing-commands definition editing-table) @@ -247,3 +291,6 @@ 'editing-table '((#\t :control))) +(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*) + 'deletion-table + '((#\k :control))) \ No newline at end of file

1 0

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

01 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv23856/Doc Modified Files: climacs-user.texi Log Message: Added mention of new documentation commands to the user manual. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 22:41:05 1.8 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 23:11:19 1.9 @@ -564,7 +564,7 @@ with. Most of these topics are obtained by some order using the @kbd{C-h} @kindex C-h -prefex key. The key following @kbd{C-h} determines what kind of help +prefix key. The key following @kbd{C-h} determines what kind of help information is displayed. @menu @@ -573,6 +573,18 @@ * Help finding an order for a command:: @end menu +@node Help with a command +@section Help with a command + +To get documentation about a particular command, use the order @kbd{C-h +f} +@kindex C-h f +(@command{Describe Command}). You will be prompted for +the name of a command, and if you provide a valid command name, a pane +containing information about which function the command calls, which +gestures the command can be invoked through, as well as a description of +the command, will be displayed. + @node Help with a key binding @section Help with a key binding @@ -593,6 +605,26 @@ command name will be displayed in the minibuffer. Otherwise, a message indicating that the key is not bound to a command will be displayed. +For more detailed information, use the order @kbd{C-h c} +@kindex C-h k +(@command{Describe Key}). You will be prompted for a key sequence, and +if the key sequence you provide is bound to a command, documentation for +that command, as well as any arguments the given key binding calls the +command with, will be shown. + +@node Help finding a command +@section Help findind a command + +If you do not know which commands are applicable to a given situation, +you can use the order @kbd{C-h a} +@kindex C-h a +(@command{Apropos Command}) to perform a keyword-based search for +commands. You will be prompted for a keyword, after which Climacs will +search through the available commands for commands that are connected to +the keyword. If commands are found, they will be displayed in a pane +along with the gestures you can use to invoke them. You can also click +on the names of the commands to get more thorough documentation. + @node Help finding an order for a command @section Help finding an order for a command

1 0

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

01 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv20213/Doc Modified Files: climacs-user.texi Log Message: The entry point is in the CLIMACS-GUI package. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2005/10/19 18:03:07 1.7 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 22:41:05 1.8 @@ -195,7 +195,7 @@ @emph{expression} at the prompt of a @cl{} @emph{listener} such as: @lisp -CL-USER> (climacs:climacs) +CL-USER> (climacs-gui:climacs) @end lisp You exit from @climacs{} by typing @kbd{C-x C-c} (@command{Quit}).

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