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