climacs-cvs May 2006

climacs-cvs@common-lisp.net

3 participants
68 discussions

[climacs-cvs] CVS climacs
by dmurray 14 May '06

14 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18370 Modified Files: base.lisp file-commands.lisp packages.lisp pane.lisp search-commands.lisp Log Message: Undo fundamental/basic breakage. Sorry. Also add String Search, Reverse String Search, Word Search and Reverse Word Search commands. --- /project/climacs/cvsroot/climacs/base.lisp 2006/05/12 18:59:05 1.48 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/05/14 20:35:44 1.49 @@ -745,6 +745,11 @@ return i finally (return nil)))) +(defun search-word-backward (mark word) + (let ((offset (buffer-search-word-backward (buffer mark) (offset mark) word))) + (when offset + (setf (offset mark) offset)))) + (defun buffer-search-word-forward (buffer offset word &key (test #'eql)) "Return the smallest offset of BUFFER >= OFFSET containing WORD as a word or NIL if no such offset exists" @@ -757,5 +762,12 @@ (buffer-looking-at buffer i word :test test) (not (and (< j blen) (constituentp (buffer-object buffer j))))) + ;; should this be (+ i wlen)? jqs 2006-05-14 return i finally (return nil)))) + +(defun search-word-forward (mark word) + (let ((wlen (length word)) + (offset (buffer-search-word-forward (buffer mark) (offset mark) word))) + (when offset + (setf (offset mark) (+ offset wlen))))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/14 07:13:43 1.17 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/14 20:35:44 1.18 @@ -127,7 +127,7 @@ :test (lambda (x y) (member x y :test #'string-equal)) :key #'climacs-syntax::syntax-description-pathname-types)) - 'fundamental-syntax)) + 'basic-syntax)) (defun evaluate-attributes (buffer options) "Evaluate the attributes `options' and modify `buffer' as --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/14 09:37:01 1.95 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/14 20:35:44 1.96 @@ -144,7 +144,7 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain :undo :climacs-fundamental-syntax) + :climacs-syntax :flexichain :undo) (:export #:climacs-buffer #:needs-saving #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only @@ -170,7 +170,7 @@ (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-abbrev :climacs-syntax :climacs-fundamental-syntax + :climacs-abbrev :climacs-syntax :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa) ;;(:import-from :lisp-string) (:export :climacs ; Main entry point. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/14 07:13:43 1.42 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/05/14 20:35:44 1.43 @@ -255,7 +255,7 @@ (declare (ignore args)) (with-slots (syntax point) buffer (setf syntax (make-instance - 'fundamental-syntax :buffer (implementation buffer)) + 'basic-syntax :buffer (implementation buffer)) point (clone-mark (low-mark buffer) :right)))) (defmethod (setf syntax) :after (syntax (buffer climacs-buffer)) --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/12 16:52:33 1.2 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/14 20:35:44 1.3 @@ -30,6 +30,46 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; String search + +(define-command (com-string-search :name t :command-table search-table) + ((string 'string :prompt "Search string")) + "Prompt for a string and search forward for it. +If found, leaves point after string. If not, leaves point where it is." + (let* ((pane (current-window)) + (point (point pane))) + (search-forward point string))) + +(define-command (com-reverse-string-search :name t :command-table search-table) + ((string 'string :prompt "Search string")) + "Prompt for a string and search backward for it. +If found, leaves point before string. If not, leaves point where it is." + (let* ((pane (current-window)) + (point (point pane))) + (search-backward point string))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Word search + +(define-command (com-word-search :name t :command-table search-table) + ((word 'string :prompt "Search word")) + "Prompt for a whitespace delimited word and search forward for it. +If found, leaves point after the word. If not, leaves point where it is." + (let* ((pane (current-window)) + (point (point pane))) + (climacs-base::search-word-forward point word))) + +(define-command (com-reverse-word-search :name t :command-table search-table) + ((word 'string :prompt "Search word")) + "Prompt for a whitespace delimited word and search backward for it. +If found, leaves point before the word. If not, leaves point where it is." + (let* ((pane (current-window)) + (point (point pane))) + (climacs-base::search-word-backward point word))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Incremental search (make-command-table 'isearch-climacs-table :errorp nil) @@ -445,5 +485,3 @@ (multiple-query-replace-set-key '(#\q) 'com-query-replace-exit) (multiple-query-replace-set-key '(#\y) 'com-multiple-query-replace-replace) (multiple-query-replace-set-key '(#\n) 'com-multiple-query-replace-skip) - -

1 0

[climacs-cvs] CVS climacs
by crhodes 14 May '06

14 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25774 Modified Files: gui.lisp Log Message: A few bells and whistles: * add a command argument for kill-buffer, rather than an accept in the body; * when running execute-frame-command, only update syntax etc. when the frame argument is also *application-frame*; * climacs implementations of read-only and modified widgets for the info pane. Ideally that should be ESA functionality, but it didn't look to me that the info pane was well factored yet. * #+sbcl implementation of climacs-as-cl:ed. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/13 17:19:10 1.214 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/14 17:42:21 1.215 @@ -223,6 +223,33 @@ (clim-sys:make-process #'run :name process-name) (run)))) +(define-presentation-type read-only ()) +(define-presentation-method highlight-presentation + ((type read-only) record stream state) + nil) +(define-presentation-type modified ()) +(define-presentation-method highlight-presentation + ((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)) @@ -230,16 +257,24 @@ (top (top master-pane)) (bot (bot master-pane))) (princ " " pane) - (princ (cond ((and (needs-saving buffer) - (read-only-p buffer) - "%*")) - ((needs-saving buffer) "**") - ((read-only-p buffer) "%%") - (t "--")) - pane) + (with-output-as-presentation (pane buffer 'read-only) + (princ (cond + ((read-only-p buffer) "%") + ((needs-saving buffer) "*") + (t "-")) + pane)) + (with-output-as-presentation (pane buffer 'modified) + (princ (cond + ((needs-saving buffer) "*") + ((read-only-p buffer) "%") + (t "-")) + pane)) (princ " " pane) (with-text-face (pane :bold) - (format pane "~25A" (name buffer))) + (with-output-as-presentation (pane buffer 'buffer) + (format pane "~A" (name buffer))) + ;; FIXME: bare 25. + (format pane "~V@T" (- 25 (length (name buffer))))) (format pane " ~A " (cond ((and (mark= size bot) (mark= 0 top)) @@ -305,10 +340,12 @@ (beep) (display-message "Buffer is read only"))))) (defmethod execute-frame-command :after ((frame climacs) command) - (loop for buffer in (buffers frame) - do (update-syntax buffer (syntax buffer)) - do (when (modified-p buffer) - (setf (needs-saving buffer) t)))) + (when (eq frame *application-frame*) + (loop for buffer in (buffers frame) + do (when (syntax buffer) + (update-syntax buffer (syntax buffer))) + do (when (modified-p buffer) + (setf (needs-saving buffer) t))))) (defmethod find-applicable-command-table ((frame climacs)) (or @@ -482,19 +519,38 @@ (defmethod kill-buffer ((symbol (eql 'nil))) (kill-buffer (buffer (current-window)))) -(define-command (com-kill-buffer :name t :command-table pane-table) () +(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." - (let ((buffer (accept 'buffer - :prompt "Kill buffer" - :default (buffer (current-window)) - :default-type 'buffer))) - (kill-buffer buffer))) + (kill-buffer buffer)) -(set-key 'com-kill-buffer +(set-key `(com-kill-buffer ,*unsupplied-argument-marker*) 'pane-table '((#\x :control) (#\k))) +#+sbcl +(defun ed-in-climacs (thing) + (let ((frame-manager (find-frame-manager))) + (when frame-manager + (let ((climacs-frame (find-if (lambda (x) (typep x 'climacs)) + (frame-manager-frames frame-manager)))) + (when climacs-frame + (typecase thing + ((or pathname string) + (execute-frame-command + climacs-frame `(com-find-file ,(pathname thing))) + t) + ((or symbol cons) + ;; FIXME: do something + nil))))))) + +#+sbcl +(pushnew 'ed-in-climacs sb-ext:*ed-functions*) + ;;; For the ESA help functions. (defmethod help-stream ((frame climacs) title)

1 0

[climacs-cvs] CVS climacs
by thenriksen 14 May '06

14 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22453 Modified Files: packages.lisp Log Message: Moved use of :climacs-pane package to after its definition. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/14 07:13:43 1.94 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/14 09:37:01 1.95 @@ -127,11 +127,6 @@ #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region)) -(defpackage :climacs-fundamental-syntax - (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) - (:export #:fundamental-syntax)) - (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size @@ -187,6 +182,11 @@ :mark :insert-character)) +(defpackage :climacs-fundamental-syntax + (:use :clim-lisp :clim :climacs-buffer :climacs-base + :climacs-syntax :flexichain :climacs-pane) + (:export #:fundamental-syntax)) + (defpackage :climacs-html-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane))

1 0

[climacs-cvs] CVS climacs
by dmurray 14 May '06

14 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31514 Modified Files: misc-commands.lisp Log Message: Linebreaks in docstrings. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/06 19:51:04 1.11 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/14 07:14:17 1.12 @@ -30,7 +30,10 @@ (define-command (com-overwrite-mode :name t :command-table editing-table) () "Toggle overwrite mode for the current mode. -When overwrite is on, an object entered on the keyboard will replace the object after the point. When overwrite is off (the default), objects are inserted at point. In both cases point is positioned after the new object." +When overwrite is on, an object entered on the keyboard +will replace the object after the point. +When overwrite is off (the default), objects are inserted at point. +In both cases point is positioned after the new object." (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) @@ -40,7 +43,9 @@ (define-command (com-not-modified :name t :command-table buffer-table) () "Clear the modified flag for the current buffer. -The modified flag is automatically set when the contents of the buffer are changed. This flag is consulted, for instance, when deciding whether to prompt you to save the buffer before killing it." +The modified flag is automatically set when the contents +of the buffer are changed. This flag is consulted, for instance, +when deciding whether to prompt you to save the buffer before killing it." (setf (needs-saving (buffer (current-window))) nil)) (set-key 'com-not-modified @@ -50,7 +55,10 @@ (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. -You must supply a numeric argument. The fill column is the column beyond which automatic line-wrapping will occur. The default fill column is 70." +You must supply a numeric argument. The fill column is +the column beyond which automatic line-wrapping will occur. + +The default fill column is 70." (set-fill-column column)) (set-key `(com-set-fill-column ,*numeric-argument-marker*) @@ -123,7 +131,8 @@ ((count 'integer :prompt "Number of Objects") (killp 'boolean :prompt "Kill?")) "Delete the object after point. -With a numeric argument, kill that many objects after (or before, if negative) point." +With a numeric argument, kill that many objects +after (or before, if negative) point." (let* ((point (point (current-window))) (mark (clone-mark point))) (forward-object mark count) @@ -146,7 +155,8 @@ ((count 'integer :prompt "Number of Objects") (killp 'boolean :prompt "Kill?")) "Delete the object before point. -With a numeric argument, kills that many objects before (or after, if negative) point." +With a numeric argument, kills that many objects +before (or after, if negative) point." (let* ((point (point (current-window))) (mark (clone-mark point))) (backward-object mark count) @@ -161,7 +171,7 @@ '(#\Backspace)) (define-command (com-zap-to-object :name t :command-table deletion-table) () - "Prompt for an object and kill the objects between point and the next occurence of that object after point. + "Prompt for an object and kill to the next occurence of that object after point. Characters can be entered in #\ format." (let* ((item (handler-case (accept 't :prompt "Zap to Object") (error () (progn (beep) @@ -174,8 +184,10 @@ (delete-range current-point (- (offset item-mark) current-offset)))) (define-command (com-zap-to-character :name t :command-table deletion-table) () - "Prompt for a character and kill the objects between point and the next occurence of that character after point. -FIXME: Accepts a string (that is, zero or more characters) terminated by a #\NEWLINE. If a zero length string signals an error. If a string of length >1, uses the first character of the string." + "Prompt for a character and kill to the next occurence of that character after point. +FIXME: Accepts a string (that is, zero or more characters) +terminated by a #\NEWLINE. If a zero length string signals an error. +If a string of length >1, uses the first character of the string." (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)? (error () (progn (beep) (display-message "Not a valid string. ") @@ -206,8 +218,13 @@ (define-command (com-transpose-objects :name t :command-table editing-table) () "Transpose the objects before and after point, advancing point. -At the end of a line transpose the previous two objects without advancing point. At the beginning of the buffer do nothing. At the beginning of any line other than the first effectively move the first object of that line to the end of the previous line. -FIXME: at the end of a single object line at the beginning of the buffer deletes that object." +At the end of a line transpose the previous two objects without +advancing point. At the beginning of the buffer do nothing. +At the beginning of any line other than the first effectively +move the first object of that line to the end of the previous line. + +FIXME: at the end of a single object line at the beginning of +the buffer deletes that object." (transpose-objects (point (current-window)))) (set-key 'com-transpose-objects @@ -217,7 +234,8 @@ (define-command (com-backward-object :name t :command-table movement-table) ((count 'integer :prompt "Number of Objects")) "Move point backward one object. -With a numeric argument, move point backward (or forward, if negative) that number of objects." +With a numeric argument, move point backward (or forward, if negative) +that number of objects." (backward-object (point (current-window)) count)) (set-key `(com-backward-object ,*numeric-argument-marker*) @@ -231,7 +249,8 @@ (define-command (com-forward-object :name t :command-table movement-table) ((count 'integer :prompt "Number of Objects")) "Move point forward one object. -With a numeric argument, move point forward (or backward, if negative) that number of objects." +With a numeric argument, move point forward (or backward, if negative) +that number of objects." (forward-object (point (current-window)) count)) (set-key `(com-forward-object ,*numeric-argument-marker*) @@ -267,8 +286,14 @@ (define-command (com-transpose-words :name t :command-table editing-table) () "Transpose the words around point, leaving point at the end of them. -With point in the whitespace between words, transpose the words before and after point. With point inside a word, transpose that word with the next one. With point before the first word of the buffer, transpose the first two words of the buffer. -FIXME: with point after the penultimate word of the buffer, or if there are <2 words in the buffer, Strange Things (TM) happen (including breaking Climacs)." +With point in the whitespace between words, transpose the words before +and after point. With point inside a word, transpose that word with +the next one. With point before the first word of the buffer, transpose +the first two words of the buffer. + +FIXME: with point after the penultimate word of the buffer, +or if there are <2 words in the buffer, Strange Things (TM) +happen (including breaking Climacs)." (transpose-words (point (current-window)))) (set-key 'com-transpose-words @@ -299,7 +324,9 @@ (define-command (com-transpose-lines :name t :command-table editing-table) () "Transpose current line and previous line, leaving point at the end of them. -If point is in the first line, transpose the first two lines. If point is in the last line of the buffer and there is no final #\Newline, add one." +If point is in the first line, transpose the first two lines. +If point is in the last line of the buffer and there is no +final #\Newline, add one." (transpose-lines (point (current-window)))) (set-key 'com-transpose-lines @@ -309,7 +336,8 @@ (define-command (com-previous-line :name t :command-table movement-table) ((numarg 'integer :prompt "How many lines?")) "Move point to the previous line. -With a numeric argument, move point up (down, if negative) that many lines. Successive line movement commands seek to respect the 'goal column'." +With a numeric argument, move point up (down, if negative) that many lines. +Successive line movement commands seek to respect the 'goal column'." (let* ((window (current-window)) (point (point window))) (unless (or (eq (previous-command window) 'com-previous-line) @@ -330,7 +358,8 @@ (define-command (com-next-line :name t :command-table movement-table) ((numarg 'integer :prompt "How many lines?")) "Move point to the next line. -With a numeric argument, move point down (up, if negative) that many lines. Successive line movement commands seek to respect the 'goal column'." +With a numeric argument, move point down (up, if negative) that many lines. +Successive line movement commands seek to respect the 'goal column'." (let* ((window (current-window)) (point (point window))) (unless (or (eq (previous-command window) 'com-previous-line) @@ -390,7 +419,12 @@ ((numarg 'integer :prompt "Kill how many lines?") (numargp 'boolean :prompt "Kill entire lines?")) "Kill the objects on the current line after point. -When at the end of a line, kill the #\Newline. With a numeric argument of 0, kill the objects on the current line before point. With a non-zero numeric argument, kill that many lines forward (backward, if negative) from point. Successive kills append to the kill ring." +When at the end of a line, kill the #\\Newline. +With a numeric argument of 0, kill the objects on the current line before point. +With a non-zero numeric argument, kill that many lines forward (backward, +if negative) from point. + +Successive kills append to the kill ring." (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-kill-line))) @@ -403,7 +437,8 @@ (define-command (com-forward-word :name t :command-table movement-table) ((count 'integer :prompt "Number of words")) "Move point to the next word end. -With a numeric argument, move point forward (backward, if negative) that many words." +With a numeric argument, move point forward (backward, if negative) +that many words." (if (plusp count) (forward-word (point (current-window)) count) (backward-word (point (current-window)) (- count)))) @@ -419,7 +454,8 @@ (define-command (com-backward-word :name t :command-table movement-table) ((count 'integer :prompt "Number of words")) "Move point to the previous word beginning. -With a numeric argument, move point backward (forward, if negative) that many words." +With a numeric argument, move point backward (forward, if negative) +that many words." (backward-word (point (current-window)) count)) (set-key `(com-backward-word ,*numeric-argument-marker*) @@ -459,7 +495,10 @@ (define-command (com-kill-word :name t :command-table deletion-table) ((count 'integer :prompt "Number of words")) "Kill from point until the next word end. -With a numeric argument, kill forward (backward, if negative) that many words. Successive kills append to the kill ring." +With a numeric argument, kill forward (backward, if negative) +that many words. + +Successive kills append to the kill ring." (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-kill-word))) @@ -472,7 +511,10 @@ (define-command (com-backward-kill-word :name t :command-table deletion-table) ((count 'integer :prompt "Number of words")) "Kill from point until the previous word beginning. -With a numeric argument, kill backward (forward, if negative) that many words. Successive kills append to the kill ring." +With a numeric argument, kill backward (forward, if negative) +that many words. + +Successive kills append to the kill ring." (let* ((pane (current-window)) (point (point pane)) (concatenate-p (eq (previous-command pane) 'com-backward-kill-word))) @@ -485,7 +527,11 @@ (define-command (com-mark-word :name t :command-table marking-table) ((count 'integer :prompt "Number of words")) "Place mark at the next word end. -With a positive numeric argument, place mark at the end of that many words forward. With a negative numeric argument, place mark at the beginning of that many words backward. Successive invocations extend the selection." +With a positive numeric argument, place mark at the end of +that many words forward. With a negative numeric argument, +place mark at the beginning of that many words backward. + +Successive invocations extend the selection." (let* ((pane (current-window)) (point (point pane)) (mark (mark pane))) @@ -540,7 +586,12 @@ (define-command (com-capitalize-word :name t :command-table case-table) () "Capitalize the next word. -If point is in a word, convert the next character to upper case and the remaining letters in the word to lower case. If point is before the start of a word, convert the first character of that word to upper case and the rest of the letters to lower case. Leave point at the word end." +If point is in a word, convert the next character to +upper case and the remaining letters in the word to lower case. +If point is before the start of a word, convert the first character +of that word to upper case and the rest of the letters to lower case. + +Leave point at the word end." (capitalize-word (point (current-window)))) (set-key 'com-capitalize-word @@ -625,7 +676,11 @@ (define-command (com-delete-indentation :name t :command-table indent-table) () "Join current line to previous non-blank line. -Leaves a single space between the last non-whitespace object of the previous line and the first non-whitespace object of the current line, and point after that space. If there is no previous non-blank line, deletes all whitespace at the beginning of the buffer at leaves point there." +Leaves a single space between the last non-whitespace object +of the previous line and the first non-whitespace object of +the current line, and point after that space. If there is no +previous non-blank line, deletes all whitespace at the +beginning of the buffer at leaves point there." (delete-indentation (point (current-window)))) (set-key 'com-delete-indentation @@ -772,6 +827,7 @@ ((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)) count)) @@ -805,7 +861,10 @@ (define-command (com-goto-line :name t :command-table movement-table) () "Prompts for a line number, and sets point to the beginning of that line. -The first line of the buffer is 1. Giving a number <1 leaves point at the beginning of the buffer. Giving a line number larger than the number of the last line in the buffer leaves point at the beginning of the last line of the buffer." +The first line of the buffer is 1. Giving a number <1 leaves +point at the beginning of the buffer. Giving a line number +larger than the number of the last line in the buffer leaves +point at the beginning of the last line of the buffer." (goto-line (point (current-window)) (handler-case (accept 'integer :prompt "Goto Line") (error () (progn (beep) @@ -903,7 +962,9 @@ (define-command (com-rotate-yank :name t :command-table editing-table) () "Replace the immediately previously yanked objects with others. -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." +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*))) @@ -971,7 +1032,9 @@ (define-command (com-dabbrev-expand :name t :command-table editing-table) () "Expand word before point dynamically. -Search from point (first backward to the beginning of the buffer, then forward) for words for which the word before point is a prefix, inserting each in turn at point as an expansion." +Search from point (first backward to the beginning of the buffer, +then forward) for words for which the word before point is a prefix, +inserting each in turn at point as an expansion." (let* ((window (current-window)) (point (point window))) (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) window @@ -1015,7 +1078,8 @@ (define-command (com-backward-paragraph :name t :command-table movement-table) ((count 'integer :prompt "Number of paragraphs")) "Move point to the previous paragraph start. -With a numeric argument, move point backward (forward, if negative) that many paragraphs." +With a numeric argument, move point backward (forward, if negative) +that many paragraphs." (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) @@ -1030,7 +1094,8 @@ (define-command (com-forward-paragraph :name t :command-table movement-table) ((count 'integer :prompt "Number of paragraphs")) "Move point to the next paragraph end. -With a numeric argument, move point forward (backward, if negative) that many paragraphs." +With a numeric argument, move point forward (backward, if negative) +that many paragraphs." (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) @@ -1045,7 +1110,13 @@ (define-command (com-mark-paragraph :name t :command-table marking-table) ((count 'integer :prompt "Number of paragraphs")) "Place point and mark around the current paragraph. -Put point at the beginning of the current paragraph, and mark at the end. With a positive numeric argument, put mark that many paragraphs forward. With a negative numeric argument, put point at the end of the current paragraph and mark that many paragraphs backward. Successive invocations extend the selection. +Put point at the beginning of the current paragraph, and mark at the end. +With a positive numeric argument, put mark that many paragraphs forward. +With a negative numeric argument, put point at the end of the current +paragraph and mark that many paragraphs backward. + +Successive invocations extend the selection. + FIXME: when called with point already at the beginning or end of a paragraph marks 2 paras." (let* ((pane (current-window)) (point (point pane)) @@ -1067,7 +1138,8 @@ (define-command (com-backward-sentence :name t :command-table movement-table) ((count 'integer :prompt "Number of sentences")) "Move point to the previous sentence beginning. -With a numeric argument, move point backward (forward if negative) that many sentences." +With a numeric argument, move point backward (forward if negative) +that many sentences." (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) @@ -1082,7 +1154,8 @@ (define-command (com-forward-sentence :name t :command-table movement-table) ((count 'integer :prompt "Number of sentences")) "Move point to the next sentence end. -With a numeric argument, move point forward (backward if negative) that many sentences." +With a numeric argument, move point forward (backward if negative) +that many sentences." (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) @@ -1097,7 +1170,8 @@ (define-command (com-kill-sentence :name t :command-table deletion-table) ((count 'integer :prompt "Number of sentences")) "Kill the objects from point to the next sentence end. -With a numeric argument, kill forward (backward if negative) that many sentences." +With a numeric argument, kill forward (backward if negative) +that many sentences." (let* ((pane (current-window)) (point (point pane)) (mark (clone-mark point)) @@ -1115,7 +1189,8 @@ (define-command (com-backward-kill-sentence :name t :command-table deletion-table) ((count 'integer :prompt "Number of sentences")) "Kill the objects from point to the previous sentence beginning. -With a numeric argument, kill backward (forward if negative) that many sentences." +With a numeric argument, kill backward (forward if negative) +that many sentences." (let* ((pane (current-window)) (point (point pane)) (mark (clone-mark point)) @@ -1139,7 +1214,11 @@ (define-command (com-forward-page :name t :command-table movement-table) ((count 'integer :prompt "Number of pages")) "Move point to the beginning of the next page. -With a numeric argument, move point forward (backward if negative) that many pages. When no page delimeter is found, leave point at the end of the buffer. A page is delimited by the sequence #\Newline #\Page." +With a numeric argument, move point forward (backward if negative) +that many pages. When no page delimeter is found, leave point at the + end of the buffer. + +A page is delimited by the sequence #\Newline #\Page." (let* ((pane (current-window)) (point (point pane))) (if (plusp count) @@ -1160,7 +1239,11 @@ (define-command (com-backward-page :name t :command-table movement-table) ((count 'integer :prompt "Number of pages")) "Move point to the end of the previous page. -With a numeric argument, move point backward (forward if negative) that many pages. When no page delimeter is found, leave point at the beginning of the buffer. A page is delimited by the sequence #\Newline #\Page." +With a numeric argument, move point backward (forward if negative) +that many pages. When no page delimeter is found, leave point at the +beginning of the buffer. + [180 lines skipped]

1 0

[climacs-cvs] CVS climacs
by dmurray 14 May '06

14 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31448 Modified Files: pane.lisp packages.lisp file-commands.lisp Log Message: Banish Basic syntax in favour of Fundamental (and some region highlighting fiddling). --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/07 06:40:19 1.41 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/05/14 07:13:43 1.42 @@ -255,7 +255,7 @@ (declare (ignore args)) (with-slots (syntax point) buffer (setf syntax (make-instance - 'basic-syntax :buffer (implementation buffer)) + 'fundamental-syntax :buffer (implementation buffer)) point (clone-mark (low-mark buffer) :right)))) (defmethod (setf syntax) :after (syntax (buffer climacs-buffer)) @@ -626,76 +626,100 @@ ;; mark or point is above the screen, and point or mark below it ((and (null cursor-y) (null mark-y) (or (and cursor-x (null mark-x)) - (and (null cursor-x) mark-y))) - (updating-output (pane :unique-id -3) - (draw-rectangle* pane - 0 0 - (stream-text-margin pane) (bounding-rectangle-height - (window-viewport pane)) - :ink ink))) + (and (null cursor-x) mark-x))) + (let ((width (stream-text-margin pane)) + (height (bounding-rectangle-height + (window-viewport pane)))) + (updating-output (pane :unique-id -3 + :cache-value (list cursor-y mark-y cursor-x mark-x + height width ink)) + (draw-rectangle* pane + 0 0 + width height + :ink ink)))) ;; mark is above the top of the screen ((and (null mark-y) (null mark-x)) - (updating-output (pane :unique-id -3) - (draw-rectangle* pane - 0 0 - (stream-text-margin pane) cursor-y - :ink ink) - (draw-rectangle* pane - 0 cursor-y - cursor-x (+ cursor-y line-height) - :ink ink))) + (let ((width (stream-text-margin pane))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list mark-y mark-x cursor-y width)) + (draw-rectangle* pane + 0 0 + width cursor-y + :ink ink)) + (updating-output (pane :cache-value (list cursor-y cursor-x)) + (draw-rectangle* pane + 0 cursor-y + cursor-x (+ cursor-y line-height) + :ink ink))))) ;; mark is below the bottom of the screen ((and (null mark-y) mark-x) - (updating-output (pane :unique-id -3) - (draw-rectangle* pane - 0 (+ cursor-y line-height) - (stream-text-margin pane) (bounding-rectangle-height - (window-viewport pane)) - :ink ink) - (draw-rectangle* pane - cursor-x cursor-y - (stream-text-margin pane) (+ cursor-y line-height) - :ink ink))) + (let ((width (stream-text-margin pane)) + (height (bounding-rectangle-height + (window-viewport pane)))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list cursor-y width height)) + (draw-rectangle* pane + 0 (+ cursor-y line-height) + width height + :ink ink)) + (updating-output (pane :cache-value (list cursor-x cursor-y width)) + (draw-rectangle* pane + cursor-x cursor-y + width (+ cursor-y line-height) + :ink ink))))) ;; mark is at point ((and (= mark-x cursor-x) (= mark-y cursor-y)) nil) ;; mark and point are on the same line ((= mark-y cursor-y) - (updating-output (pane :unique-id -3) + (updating-output (pane :unique-id -3 + :cache-value (list offset1 offset2 ink)) (draw-rectangle* pane mark-x mark-y cursor-x (+ cursor-y line-height) :ink ink))) ;; mark and point are both visible, mark above point ((< mark-y cursor-y) - (updating-output (pane :unique-id -3) - (draw-rectangle* pane - mark-x mark-y - (stream-text-margin pane) (+ mark-y line-height) - :ink ink) - (draw-rectangle* pane - 0 cursor-y - cursor-x (+ cursor-y line-height) - :ink ink) - (draw-rectangle* pane - 0 (+ mark-y line-height) - (stream-text-margin pane) cursor-y - :ink ink))) + (let ((width (stream-text-margin pane))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list mark-x mark-y width)) + (draw-rectangle* pane + mark-x mark-y + width (+ mark-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list cursor-x cursor-y)) + (draw-rectangle* pane + 0 cursor-y + cursor-x (+ cursor-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list mark-y cursor-y width)) + (draw-rectangle* pane + 0 (+ mark-y line-height) + width cursor-y + :ink ink))))) ;; mark and point are both visible, point above mark (t - (updating-output (pane :unique-id -3) - (draw-rectangle* pane - cursor-x cursor-y - (stream-text-margin pane) (+ cursor-y line-height) - :ink ink) - (draw-rectangle* pane - 0 mark-y - mark-x (+ mark-y line-height) - :ink ink) - (draw-rectangle* pane - 0 (+ cursor-y line-height) - (stream-text-margin pane) mark-y - :ink ink))))))) + (let ((width (stream-text-margin pane))) + (updating-output (pane :unique-id -3 + :cache-value ink) + (updating-output (pane :cache-value (list cursor-x cursor-y width)) + (draw-rectangle* pane + cursor-x cursor-y + width (+ cursor-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list mark-x mark-y)) + (draw-rectangle* pane + 0 mark-y + mark-x (+ mark-y line-height) + :ink ink)) + (updating-output (pane :cache-value (list cursor-y mark-y width)) + (draw-rectangle* pane + 0 (+ cursor-y line-height) + width mark-y + :ink ink))))))))) (defmethod highlight-region ((pane climacs-pane) (mark1 mark) (mark2 mark) &optional (ink (compose-in +green+ (make-opacity .1)))) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/06 19:51:04 1.93 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/14 07:13:43 1.94 @@ -127,6 +127,11 @@ #:line-comment-region #:comment-region #:line-uncomment-region #:uncomment-region)) +(defpackage :climacs-fundamental-syntax + (:use :clim-lisp :clim :climacs-buffer :climacs-base + :climacs-syntax :flexichain :climacs-pane) + (:export #:fundamental-syntax)) + (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size @@ -144,7 +149,7 @@ (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain :undo) + :climacs-syntax :flexichain :undo :climacs-fundamental-syntax) (:export #:climacs-buffer #:needs-saving #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only @@ -170,7 +175,7 @@ (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-abbrev :climacs-syntax + :climacs-abbrev :climacs-syntax :climacs-fundamental-syntax :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa) ;;(:import-from :lisp-string) (:export :climacs ; Main entry point. @@ -182,11 +187,6 @@ :mark :insert-character)) -(defpackage :climacs-fundamental-syntax - (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) - (:export)) - (defpackage :climacs-html-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane)) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/10 20:33:45 1.16 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/14 07:13:43 1.17 @@ -127,7 +127,7 @@ :test (lambda (x y) (member x y :test #'string-equal)) :key #'climacs-syntax::syntax-description-pathname-types)) - 'basic-syntax)) + 'fundamental-syntax)) (defun evaluate-attributes (buffer options) "Evaluate the attributes `options' and modify `buffer' as

1 0

[climacs-cvs] CVS climacs
by dmurray 13 May '06

13 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20027 Modified Files: window-commands.lisp gui.lisp Log Message: Changes relating to the new help facilities in ESA. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/05/12 10:31:56 1.7 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/05/13 17:19:10 1.8 @@ -103,20 +103,6 @@ (full-redisplay current-window) new-pane)))) -(define-command (com-describe-bindings :name t :command-table climacs-help-table) - ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?")) - (let* ((window (current-window)) - (buffer (buffer (current-window))) - (stream (typeout-window - (format nil "~10THelp: Describe Bindings for ~A" (name buffer)))) - (command-table (command-table window))) - (esa::describe-bindings stream command-table - (if sort-by-keystrokes - #'esa::sort-by-keystrokes - #'esa::sort-by-name)))) - -(set-key `(com-describe-bindings ,*numeric-argument-p*) 'climacs-help-table '((#\h :control) (#\b))) - (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 --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/12 10:31:56 1.213 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/13 17:19:10 1.214 @@ -495,48 +495,8 @@ 'pane-table '((#\x :control) (#\k))) -;;; Commands for calling the ESA help functions. +;;; For the ESA help functions. -(define-command (com-describe-binding :name t :command-table help-table) - () - "Display documentation for the command invoked by a giving gesture sequence. -When invoked, this command will wait for user input. If the user inputs a gesture -sequence bound to a command available in the syntax of the current buffer, -documentation and other details will be displayed in a typeout pane." - (let ((command-table (esa:find-applicable-command-table *application-frame*))) - (multiple-value-bind (command gestures) - (esa::read-gestures-for-help command-table) - (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" - (mapcar #'esa:gesture-name gestures)))) - (if command - (let ((out-stream (typeout-window (format nil "~10THelp: Describe Binding for ~A" gesture-name)))) - (describe-command-binding-to-stream gesture-name command - :command-table command-table - :stream out-stream)) - (display-message "Unbound gesture: ~A" gesture-name)))))) +(defmethod help-stream ((frame climacs) title) + (typeout-window (format nil "~10T~A" title))) -(define-command (com-describe-command :name t :command-table climacs-help-table) - ((command 'command-name)) - "Display documentation for the given command." - (unless command - (setf command (accept 'command-name))) - (let ((command-table (esa::find-applicable-command-table *application-frame*)) - (out-stream (typeout-window (format nil "~10THelp: Describe Command for ~A" command)))) - (describe-command-to-stream command - :command-table command-table - :stream out-stream))) - -(set-key 'com-describe-binding - 'climacs-help-table - '((#\h :control) (#\k))) - -(set-key '(com-describe-command nil) - 'climacs-help-table - '((#\h :control) (#\f))) - -(define-presentation-to-command-translator describe-command - (command-name com-describe-command climacs-help-table - :gesture :select - :documentation "Describe command") - (object) - (list object))

1 0

[climacs-cvs] CVS esa
by dmurray 13 May '06

13 May '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv19376 Modified Files: packages.lisp Log Message: Some package cleanups from the help changes. --- /project/climacs/cvsroot/esa/packages.lisp 2006/05/10 09:52:05 1.4 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/05/13 17:15:10 1.5 @@ -9,9 +9,7 @@ #:esa-top-level #:simple-command-loop #:global-esa-table #:keyboard-macro-table #:help-table - #:describe-command-binding-to-stream - #:describe-command-to-stream - #:gesture-name + #:help-stream #:set-key #:find-applicable-command-table #:esa-command-parser

1 0

[climacs-cvs] CVS esa
by dmurray 13 May '06

13 May '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv15009 Modified Files: esa.lisp Log Message: Moved more help functionality into base ESA. There is now a gf HELP-STREAM FRAME TITLE that provides the stream for the help commands to operate on. The basic method provides a separate output window. (Climacs provides a typeout pane.) ESA help commands now comprise: Describe Key Briefly C-h c Where Is C-h w Describe Bindings C-h b Describe Key C-h k Describe Command C-h f Apropos Command C-h a Command docstrings should consist of a first line with a short description, followed by paragraphs separated by a double #\Newline. (There is no need to put a second #\Newline between the first line and the rest of the docstring. The rest of the docstring will be wrapped to the [initial] width of the help stream.) Much of this was just moving Mr Henriksen's code to ESA. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/12 18:51:54 1.18 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/13 16:48:04 1.19 @@ -643,7 +643,7 @@ (define-command-table global-esa-table) (define-command (com-quit :name t :command-table global-esa-table) () - "Exit Climacs. + "Exit. First ask if modified buffers should be saved. If you decide not to save a modified buffer, you will be asked to confirm your decision to exit." (frame-exit *application-frame*)) @@ -673,6 +673,16 @@ ;;; ;;; Help +(defgeneric help-stream (frame title)) + +(defmethod help-stream (frame title) + (open-window-stream + :label title + :input-buffer (#+mcclim climi::frame-event-queue + #-mcclim silica:frame-input-buffer + *application-frame*) + :width 400)) + (defun read-gestures-for-help (command-table) (loop for gestures = (list (esa-read-gesture)) then (nconc gestures (list (esa-read-gesture))) @@ -786,6 +796,16 @@ (helper start-table)) results)) +(defun find-all-commands-and-keystrokes-with-inheritance (start-table) + (let ((results '())) + (map-over-command-table-commands + (lambda (command) + (let ((keys (find-keystrokes-for-command-with-inheritance command start-table))) + (push (cons command keys) results))) + start-table + :inherited t) + results)) + (defun sort-by-name (list) (sort list #'string< :key (lambda (item) (symbol-name (if (listp (cdr item)) @@ -831,31 +851,56 @@ (defun print-docstring-for-command (command-name command-table &optional (stream *standard-output*)) "Print documentation for `command-name', which should - be a symbol bound to a function, to `stream. If no + be a symbol bound to a function, to `stream'. If no documentation can be found, this fact will be printed to the stream." (declare (ignore command-table)) ;; This needs more regex magic. Also, it is only an interim ;; solution. (with-text-style (stream '(:sans-serif nil nil)) - (let ((command-documentation (or (documentation command-name 'function) - "This command is not documented."))) - - ;; Remove single linebreaks but preserve double linebreaks. - (loop for char across command-documentation - with newline = nil - do - (if (char-equal char #\Newline) - (if newline - (progn - (terpri stream) - (terpri stream) - (setf newline nil)) - (setf newline t)) - (progn - (when newline - (princ #\Space stream) - (setf newline nil)) - (princ char stream))))))) + (let* ((command-documentation (or (documentation command-name 'function) + "This command is not documented.")) + (first-newline (position #\Newline command-documentation)) + (first-line (subseq command-documentation 0 first-newline))) + ;; First line is special + (format stream "~A~%" first-line) + (when first-newline + (let* ((rest (subseq command-documentation first-newline)) + (paras (delete "" + (loop for start = 0 then (+ 2 end) + for end = (search '(#\Newline #\Newline) rest :start2 start) + collecting + (nsubstitute #\Space #\Newline (subseq rest start end)) + while end) + :test #'string=))) + (dolist (para paras) + (terpri stream) + (let ((words (loop with length = (length para) + with index = 0 + with start = 0 + while (< index length) + do (loop until (>= index length) + while (member (char para index) '(#\Space #\Tab)) + do (incf index)) + (setf start index) + (loop until (>= index length) + until (member (char para index) '(#\Space #\Tab)) + do (incf index)) + until (= start index) + collecting (string-trim '(#\Space #\Tab #\Newline) + (subseq para start index))))) + (loop with margin = (stream-text-margin stream) + with space-width = (stream-character-width stream #\Space) + with current-width = 0 + for word in words + for word-width = (stream-string-width stream word) + when (> (+ word-width current-width) + margin) + do (terpri stream) + (setf current-width 0) + do (princ word stream) + (princ #\Space stream) + (incf current-width (+ word-width space-width)))) + (terpri stream))))))) (defun describe-command-binding-to-stream (gesture command &key (command-table (find-applicable-command-table *application-frame*)) @@ -872,27 +917,34 @@ command-table))) (with-text-style (stream '(:sans-serif nil nil)) (princ "The gesture " stream) - (with-text-style (stream '(:fix nil nil)) + (with-drawing-options (stream :ink +dark-blue+ + :text-style '(:fix nil nil)) (princ gesture stream)) (princ " is bound to the command " stream) (if (command-present-in-command-table-p command-name real-command-table) - (present command-name `(command-name :command-table ,command-table) :stream stream) + (with-text-style (stream '(nil :bold nil)) + (present command-name `(command-name :command-table ,command-table) :stream stream)) (present command-name 'symbol :stream stream)) (princ " in " stream) (present real-command-table 'command-table :stream stream) (format stream ".~%") (when command-args - (apply #'format stream "This binding invokes the command with the arguments ~@{~A~^, ~}.~%" command-args)) + (apply #'format stream + "This binding invokes the command with the arguments ~@{~A~^, ~}.~%" + command-args)) (terpri stream) - (print-docstring-for-command command-name command-table stream)))) + (print-docstring-for-command command-name command-table stream) + (scroll-extent stream 0 0)))) -(defun describe-command-to-stream (command-name &key - (command-table (esa:find-applicable-command-table *application-frame*)) - (stream *standard-output*)) +(defun describe-command-to-stream + (command-name &key + (command-table (find-applicable-command-table *application-frame*)) + (stream *standard-output*)) "Describe `command' to `stream'." (let ((keystrokes (find-keystrokes-for-command-with-inheritance command-name command-table))) (with-text-style (stream '(:sans-serif nil nil)) - (present command-name `(command-name :command-table ,command-table) :stream stream) + (with-text-style (stream '(nil :bold nil)) + (present command-name `(command-name :command-table ,command-table) :stream stream)) (princ " calls the function " stream) (present command-name 'symbol :stream stream) (princ " and is accessible in " stream) @@ -905,14 +957,16 @@ (when (plusp (length keystrokes)) (princ "It is bound to " stream) (loop for gestures-list on (first keystrokes) - do (with-text-style (stream '(:fix nil nil)) + do (with-drawing-options (stream :ink +dark-blue+ + :text-style '(:fix nil nil)) (format stream "~{~A~^ ~}" (mapcar #'gesture-name (reverse (first gestures-list))))) when (not (null (rest gestures-list))) do (princ ", " stream)) (terpri stream)) (terpri stream) - (print-docstring-for-command command-name command-table stream)))) + (print-docstring-for-command command-name command-table stream) + (scroll-extent stream 0 0)))) ;;; help commands @@ -950,16 +1004,10 @@ (define-command (com-describe-bindings :name t :command-table help-table) ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?")) - "Pop up a help window showing which keys invoke which commands. + "Show which keys invoke which commands. Without a numeric prefix, sorts the list by command name. With a numeric prefix, sorts by key." - (let* ((window (car (windows *application-frame*))) - (stream (open-window-stream - :label (format nil "Help: Describe Bindings") - :input-buffer (#+mcclim climi::frame-event-queue - #-mcclim silica:frame-input-buffer - *application-frame*) - :width 400)) - (command-table (command-table window))) + (let ((stream (help-stream *application-frame* (format nil "Help: Describe Bindings"))) + (command-table (find-applicable-command-table *application-frame*))) (describe-bindings stream command-table (if sort-by-keystrokes #'sort-by-keystrokes @@ -967,6 +1015,117 @@ (set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b))) +(define-command (com-describe-key :name t :command-table help-table) + () + "Display documentation for the command invoked by a given gesture sequence. +When invoked, this command will wait for user input. If the user inputs a gesture +sequence bound to a command available in the syntax of the current buffer, +documentation and other details will be displayed in a typeout pane." + (let ((command-table (find-applicable-command-table *application-frame*))) + (display-message "Describe Key:") + (redisplay-frame-panes *application-frame*) + (multiple-value-bind (command gestures) + (read-gestures-for-help command-table) + (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" + (mapcar #'gesture-name gestures)))) + (if command + (let ((out-stream + (help-stream *application-frame* + (format nil "~10THelp: Describe Key for ~A" gesture-name)))) + (describe-command-binding-to-stream gesture-name command + :command-table command-table + :stream out-stream)) + (display-message "Unbound gesture: ~A" gesture-name)))))) + +(set-key 'com-describe-key + 'help-table + '((#\h :control) (#\k))) + +(define-command (com-describe-command :name t :command-table help-table) + ((command 'command-name :prompt "Describe command")) + "Display documentation for the given command." + (let* ((command-table (find-applicable-command-table *application-frame*)) + (out-stream (help-stream *application-frame* + (format nil "~10THelp: Describe Command for ~A" + (command-line-name-for-command command + command-table + :errorp nil))))) + (describe-command-to-stream command + :command-table command-table + :stream out-stream))) + +(set-key `(com-describe-command ,*unsupplied-argument-marker*) + 'help-table + '((#\h :control) (#\f))) + +(define-presentation-to-command-translator describe-command + (command-name com-describe-command help-table + :gesture :select + :documentation "Describe command") + (object) + (list object)) + +(define-command (com-apropos-command :name t :command-table help-table) + ((words '(sequence string) :prompt "Search word(s)")) + "Shows commands with documentation matching the search words. +Words are comma delimited. When more than two words are given, the documentation must match any two." + ;; 23.8.6 "It is unspecified whether accept returns a list or a vector." + (setf words (coerce words 'list)) + (when words + (let* ((command-table (find-applicable-command-table *application-frame*)) + (results (loop for (function . keys) + in (find-all-commands-and-keystrokes-with-inheritance + command-table) + when (consp function) + do (setq function (car function)) + when (let ((documentation (or (documentation function 'function) "")) + (score 0)) + (cond + ((> (length words) 1) + (loop for word in words + until (> score 1) + when (or + (search word (symbol-name function) + :test #'char-equal) + (search word documentation :test #'char-equal)) + do (incf score) + finally (return (> score 1)))) + (t (or + (search (first words) (symbol-name function) + :test #'char-equal) + (search (first words) documentation :test #'char-equal))))) + collect (cons function keys)))) + (if (null results) + (display-message "No results for ~{~A~^, ~}" words) + (let ((out-stream (help-stream *application-frame* + (format nil "~10THelp: Apropos ~{~A~^, ~}" + words)))) + (loop for (command . keys) in results + for documentation = (or (documentation command 'function) + "Not documented.") + do (with-text-style (out-stream '(:sans-serif :bold nil)) + (present command + `(command-name :command-table ,command-table) + :stream out-stream)) + (with-drawing-options (out-stream :ink +dark-blue+ + :text-style '(:fix nil nil)) + (format out-stream "~30T~:[M-x ... RETURN~;~:*~{~A~^, ~}~]" + (mapcar (lambda (keystrokes) + (format nil "~{~A~^ ~}" + (mapcar #'gesture-name (reverse keystrokes)))) + (car keys)))) + (with-text-style (out-stream '(:sans-serif nil nil)) + (format out-stream "~&~2T~A~%" + (subseq documentation 0 (position #\Newline documentation)))) + count command into length + finally (change-space-requirements out-stream + :height (* length (stream-line-height out-stream))) + (scroll-extent out-stream 0 0))))))) + +(set-key `(com-apropos-command ,*unsupplied-argument-marker*) + 'help-table + '((#\h :control) (#\a))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Keyboard macros

1 0

[climacs-cvs] CVS climacs
by dmurray 12 May '06

12 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22311 Modified Files: base.lisp Log Message: Ooops. The other part of the Multiple Query Replace change: have re-search-forward and re-search-backward return the other useful value. --- /project/climacs/cvsroot/climacs/base.lisp 2006/04/30 15:12:05 1.47 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/05/12 18:59:05 1.48 @@ -714,7 +714,8 @@ (multiple-value-bind (i j) (buffer-re-search-forward a (buffer mark) (offset mark)) (when i - (setf (offset mark) j))))) + (setf (offset mark) j) + (values mark i))))) (defun re-search-backward (mark re) "move MARK backward before the first occurence of string matching RE @@ -726,7 +727,8 @@ (buffer-re-search-backward a (buffer mark) (1- (offset mark))) (declare (ignorable j)) (when i - (setf (offset mark) i))))) + (setf (offset mark) i) + (values mark j))))) (defun buffer-search-word-backward (buffer offset word &key (test #'eql)) "return the largest offset of BUFFER <= (- OFFSET (length WORD))

1 0

[climacs-cvs] CVS esa
by dmurray 12 May '06

12 May '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv22131 Modified Files: esa.lisp Log Message: Wrapped simple-command-loop in a handler-case to deal with abort appropriately. Now C-g during an Isearch doesn't leave the Isearch mode active. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/11 15:36:56 1.17 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/12 18:51:54 1.18 @@ -540,22 +540,25 @@ (let ((gesture (gensym)) (item (gensym)) (command (gensym))) - `(progn - (redisplay-frame-panes *application-frame*) - (loop while ,loop-condition - as ,gesture = (esa-read-gesture) - as ,item = (find-gestures-with-inheritance (list ,gesture) ,command-table) - do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) - (setf *current-gesture* ,gesture) - (let ((,command (command-menu-item-value ,item))) - (unless (consp ,command) - (setf ,command (list ,command))) - (execute-frame-command *application-frame* - ,command))) - (t - (unread-gesture ,gesture) - ,@end-clauses)) - (redisplay-frame-panes *application-frame*))))) + `(handler-case + (progn + (redisplay-frame-panes *application-frame*) + (loop while ,loop-condition + as ,gesture = (esa-read-gesture) + as ,item = (find-gestures-with-inheritance (list ,gesture) ,command-table) + do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) + (setf *current-gesture* ,gesture) + (let ((,command (command-menu-item-value ,item))) + (unless (consp ,command) + (setf ,command (list ,command))) + (execute-frame-command *application-frame* + ,command))) + (t + (unread-gesture ,gesture) + ,@end-clauses)) + (redisplay-frame-panes *application-frame*))) + (abort-gesture () + ,@end-clauses)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs May 2006