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

[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